https://github.com/cran/ReacTran
Raw File
Tip revision: c455f23349da640f38c0a83c7127c199e7d95430 authored by Karline Soetaert on 19 July 2009, 00:00 UTC
version 1.1
Tip revision: c455f23
setup.prop.2D.R

##==============================================================================
## Attaches a property to a 2D grid
##==============================================================================

setup.prop.2D <- function(func = NULL, y.func = func, value = NULL, y.value = value, grid, ...) {

  ## check input
  gn <- names(grid)
  if (! "x.mid"  %in% gn)
    stop("error in setup.2D.prop: grid should be a list that contains x.mid")
  if (! "x.int"  %in% gn)
    stop("error in setup.2D.prop: grid should be a list that contains x.int")
  if (! "y.mid"  %in% gn)
    stop("error in setup.2D.prop: grid should be a list that contains x.mid")
  if (! "y.int"  %in% gn)
    stop("error in setup.2D.prop: grid should be a list that contains x.int")

  if (is.null(func) && is.null(value))
    stop("error in setup.prop: function and value should not be both NULL")
  if (is.null(y.func) && is.null(y.value))
    stop("error in setup.prop: y.function and y.value should not be both NULL")

  if (!is.null(value)) { # profile specification via value
    x.int <- matrix(nrow=length(grid$x.int),ncol=length(grid$y.mid),data=value)
    y.int <- matrix(nrow=length(grid$x.mid),ncol=length(grid$y.int),data=y.value)
    x.mid <- matrix(nrow=length(grid$x.mid),ncol=length(grid$y.mid),data=value)
    y.mid <- matrix(nrow=length(grid$x.mid),ncol=length(grid$y.mid),data=y.value)
  }

  if (!is.null(func)) { # profile specification via function
    x.int <- matrix(nrow=length(grid$x.int),ncol=length(grid$y.mid))
    x.mid <- matrix(nrow=length(grid$x.mid),ncol=length(grid$y.mid))

    for (i in 1:length(grid$x.int))
      x.int[i,] <- func(grid$x.int[i],grid$y.mid,...)
    for (i in 1:length(grid$x.mid))
      x.mid[i,] <- func(grid$x.mid[i],grid$y.mid,...)
  }

  if (!is.null(y.func)) { # profile specification via function
    y.int <- matrix(nrow=length(grid$x.mid),ncol=length(grid$y.int))
    y.mid <- matrix(nrow=length(grid$x.mid),ncol=length(grid$y.mid))

    for (i in 1:length(grid$x.mid))
      y.int[i,] <- y.func(grid$x.mid[i],grid$y.int,...)
    for (i in 1:length(grid$x.mid))
      y.mid[i,] <- y.func(grid$x.mid[i],grid$y.mid,...)
  }
  
  Res <- list(x.mid = x.mid,
              y.mid = y.mid, 
              x.int = x.int,
              y.int = y.int)
  class(Res) <- "prop.2D"
  return(Res)
}

##==============================================================================
## S3 method: Plotting of a two-dimensional grid property
##==============================================================================

contour.prop.2D <- function(x, grid, xyswap = FALSE, filled = FALSE, ...) {
  if (! filled) {
  if (xyswap)
    contour(x=grid$y.mid,y=rev(-grid$x.mid),z=t(x$x.mid),...)
  else
    contour(x=grid$x.mid,y=grid$y.mid,z=x$x.mid,...)
  } else {
    if (xyswap)
      filled.contour(x=grid$y.mid,y=rev(-grid$x.mid),z=t(x$x.mid),...)
    else
      filled.contour(x=grid$x.mid,y=grid$y.mid,z=x$x.mid,...)
  }
}
back to top