R/csbread.R

In PSPManalysis: Analysis of Physiologically Structured Population Models

#'
#' Reads the state of a structured population model from a CSB file
#'
#' \code{csbread} reads a CSB file, which is generated by \code{\link{PSPMdemo}},
#' \code{\link{PSPMequi}}, \code{\link{PSPMecodyn}} and \code{\link{PSPMevodyn}}
#' to save the entire state of the environmental variables and physiologically
#' structured populations during computations.
#'
#'   output <- csbread(csbfile = NULL, state = -1)
#'
#' @param  csbfile  (string, required)
#' \preformatted{}
#'               Name of the CSB file to be read with or without '.csb' extension.
#'
#' @param  state (integer, optional)
#' \preformatted{}
#'               If not specified \code{csbread} will list the states that are
#'               stored in the CSB file. If specified, it should be the name or index
#'               of one of the states in the CSB file.
#'
#' @return If a specific state is specified and found in the file, the state is
#' returned as a list.
#'
#' @examples
#' \dontrun{
#' PSPMdemo("Medfly", c(2, 11, 0.1, 11, 15), clean = TRUE)
#' csbread("Medfly-PGR-0000")
#'
#' csbread("Medfly-PGR-0000", 1)
#' }
#'
#' @import utils
#' @useDynLib PSPManalysis, csb2rlist
#' @export
csbread <- function(csbfile = NULL, state = -1) {
  if ((!length(csbfile)) || (!nchar(csbfile))) stop("You have to specify a file name")

  if (regexpr("\\.csb", csbfile) == (nchar(csbfile)-3)) csb.fullname <- csbfile else csb.fullname <- paste0(csbfile, ".csb")
  if (!file.exists(csb.fullname)) stop(paste('Data file', csb.fullname, 'does not exist', sep=' '))

  csb.dirname <- dirname(normalizePath(csb.fullname))
  csb.basename <- basename(normalizePath(csb.fullname))

  oldwd <- getwd()
  setwd(csb.dirname)

  if (state == -1) {
    cout <- .Call("csb2rlist", csb.basename, "list", as.integer(0), as.double(0.0))
  }
  else
  {
    # if ((!length(state)) || (regexpr("State-", state) != 1)) stop("You have to specify a valid state name of the form 'State-XXXXXXXX'")
    if (length(state)) {
      if ((is.integer(state) || is.double(state)) &&  (abs(state - round(state)) < .Machine$double.eps^0.5)) {
        selectedstate <- state
        tval <- 0.0
        if (selectedstate < 1) {
          warning("Negative index! Result shown for index set to its default value 1")
          selectedstate <- 1
        }
        cout <- .Call("csb2rlist", csb.basename, "read", as.integer(selectedstate), as.double(tval))
      } else if ( is.character(state) && (regexpr("State-", state) == 1)) {
        selectedstate <- -1
        tval <- as.numeric(sub("^State-", "", state))
        statelist <- capture.output(.Call("csb2rlist", csb.basename, "list", as.integer(0), as.double(0.0)))
        statevals <- sub("[ ]*[0-9]*:[ ]*State-", "", statelist)
        statevals <- as.numeric(statevals[4:(length(statevals)-2)])
        stateindx <- ((statevals[1:(length(statevals)-1)] - tval) * (statevals[2:length(statevals)] - tval) < (-.Machine$double.eps^0.5))
        stateindx <- (1:length(stateindx))[stateindx]
        if (length(stateindx) > 1) {
          cout <- lapply(stateindx, function(indx) {selectedstate <- indx;
                                                    if (abs(statevals[indx + 1] - tval) < abs(statevals[indx] - tval)) selectedstate <- indx + 1;
                                                    .Call("csb2rlist", csb.basename, "read", as.integer(selectedstate), as.double(tval))})
        } else if (length(stateindx) == 1) {
          selectedstate <- stateindx
          cout <- .Call("csb2rlist", csb.basename, "read", as.integer(selectedstate), as.double(tval))
        } else {
          selectedstate <- which.min(abs(statevals - tval))
          cout <- .Call("csb2rlist", csb.basename, "read", as.integer(selectedstate), as.double(tval))
        }
      } else if (is.double(state)) {
        statelist <- capture.output(.Call("csb2rlist", csb.basename, "list", as.integer(0), as.double(0.0)))
        statelist <- statelist[grep("State-", statelist)]
        statevals <- as.numeric(gsub("^[ ]*[0-9]*: State-", "", statelist))
        selectedstate <- which.min(abs(statevals - as.double(state)))
        cout <- .Call("csb2rlist", csb.basename, "read", as.integer(selectedstate), as.double(0.0))
      }
      else stop('You have to specify a valid state name of the form "State-XXXXXXXX" or its corresponding index from a call to csblist()')
    }
    else {
      selectedstate <- 0
      tval <- 0.0
      cout <- .Call("csb2rlist", csb.basename, "read", as.integer(selectedstate), as.double(tval))
    }
  }

  setwd(oldwd)
  if (length(cout)) return(cout)
}