R/bigmemory.R

In bigmemory: Manage Massive Matrices with Shared Memory and Memory-Mapped Files

#' @useDynLib bigmemory, .registration = TRUE
#' @import methods bigmemory.sri Rcpp
#' @importFrom utils head tail

# puts an '/' at the end if there isn't
format_path <- function(path) {
  paste0(sub(file.path("", "$"), "", path), .Platform$file.sep)
}

#############################################################################
# This function is used to match up a vector of column names to the
# entire set of column names, providing the proper column indices.
# The name choice was based on the phrase "multiple map" though
# perhaps we should have made a different choice.

mmap <- function(x, y) {
  if (is.null(x)) return(NULL)
  ans <- match(x, y)
  if (any(is.na(ans))) stop("Couldn't find a match to one of the arguments.")
  return(ans)
}

checkReadOnly <- function(x)
{
  if (is.readonly(x)) {
    stop("you may not modify a read-only big.matrix object")
  }
}

#############################################################################

#' @template big.matrix_class_template
#' @export
setClass('big.matrix', representation(address='externalptr'))

setClass('descriptor', representation(description='list'))

#' @template big.matrix.descriptor_class_template
#' @export
setClass('big.matrix.descriptor', contains='descriptor')

setGeneric('description', function(x) standardGeneric('description'))

#' @rdname attach.big.matrix
#' @export
setMethod('describe', signature(x='big.matrix'),
  function(x)
  {
    return(new('big.matrix.descriptor', description=DescribeBigMatrix(x)))
  })

#' @importFrom uuid UUIDgenerate
#' @template core_template
#' @export
big.matrix <- function(nrow, ncol, type=options()$bigmemory.default.type,
                       init=NULL, dimnames=NULL, separated=FALSE,
                       backingfile=NULL, backingpath=NULL, descriptorfile=NULL,
                       binarydescriptor=FALSE,
                       shared=options()$bigmemory.default.shared)
{
  if (!is.null(backingfile))
  {
    if (!shared) warning("All filebacked objects are shared.")
    return(filebacked.big.matrix(nrow=nrow, ncol=ncol, type=type, init=init,
                               dimnames=dimnames, separated=separated,
                               backingfile=backingfile, backingpath=backingpath,
                               descriptorfile=descriptorfile,
                               binarydescriptor=binarydescriptor))
  }
  if (nrow < 1 | ncol < 1)
    stop('A big.matrix must have at least one row and one column')

  typeVal <- NULL
  if (type == 'integer') typeVal <- 4
  if (type == 'float') typeVal <- 6
  if (type == 'double') typeVal <- 8
  if (type == 'short') typeVal <- 2
  if (type == 'char') typeVal <- 1
  if (type == 'raw' || type == 'byte') typeVal <- 3

  if (is.null(typeVal)) stop('invalid type')
  if (!is.null(dimnames)) {
    rownames <- dimnames[[1]]
    colnames <- dimnames[[2]]
  } else {
    rownames <- NULL
    colnames <- NULL
  }
  if (is.null(init)) init <- NA
  if (shared) {
      bunk <- UUIDgenerate()
      address <- CreateSharedMatrix(as.double(nrow),
                  as.double(ncol),as.character(colnames),as.character(rownames),
                  as.integer(typeVal), as.double(init), as.logical(separated))
  } else {
    address <- CreateLocalMatrix(as.double(nrow),
                as.double(ncol), as.character(colnames), as.character(rownames),
                as.integer(typeVal), as.double(init), as.logical(separated))
  }
  if (is.null(address)) {
    stop(paste("Error: memory could not be allocated for instance",
               "of type big.matrix"))
  }
  x <- new("big.matrix", address=address)
  if (is.null(x)) {
    stop("Error encountered when creating instance of type big.matrix")
  }
  return(x)
}

#' @rdname big.matrix
#' @export
filebacked.big.matrix <- function(nrow, ncol,
                                type=options()$bigmemory.default.type,
                                init=NULL, dimnames=NULL, separated=FALSE,
                                backingfile=NULL, backingpath=NULL,
                                descriptorfile=NULL, binarydescriptor=FALSE) {

  if (nrow < 1 | ncol < 1)
    stop('A big.matrix must have at least one row and one column')

  typeVal <- NULL
  if (type == 'integer') typeVal <- 4
  if (type == 'float') typeVal <- 6
  if (type == 'double') typeVal <- 8
  if (type == 'short') typeVal <- 2
  if (type == 'char') typeVal <- 1
  if (type == 'raw' || type == 'byte') typeVal <- 3

  if (is.null(typeVal)) stop('invalid type')

  if (!is.null(dimnames)) {
    rownames <- dimnames[[1]]
    colnames <- dimnames[[2]]
  } else {
    rownames <- NULL
    colnames <- NULL
  }

  if (is.null(backingfile)) {
    stop('You must specify a backing file')
  }

  anon.backing <- ifelse( backingfile == '', TRUE, FALSE )

  if (anon.backing) {
    backingfile <- tempfile()
    backingpath <- ""
  }

  if (is.null(descriptorfile) && !anon.backing)
  {
    warning(paste("No descriptor file given, it will be named",
                  paste(backingfile, '.desc', sep='')))
    descriptorfile <- paste(backingfile, '.desc', sep='')
  }

  if ( !anon.backing && ((basename(backingfile) != backingfile) ||
       (basename(descriptorfile) != descriptorfile)) ) {
    stop(paste("The path to the descriptor and backing file are",
               "specified with the backingpath option"))
  }

  if (is.null(backingpath)) backingpath <- ''

  backingpath <- path.expand(backingpath)

  if (backingpath != "") {
    backingpath <- paste(backingpath, '', sep=.Platform$file.sep)
  }

  if(file.exists(paste(backingpath, backingfile, sep=.Platform$file.sep))){
      stop("Backing file already exists! Either remove or specify
           different backing file")
  }

  if (backingpath == "" && dirname(backingfile) == ".") {
    backingpath <- paste(getwd(), "", sep=.Platform$file.sep)
  }

  address <- CreateFileBackedBigMatrix(as.character(backingfile),
                   as.character(backingpath), as.double(nrow),
                   as.double(ncol), as.character(colnames),
                   as.character(rownames), as.integer(typeVal),
                   as.double(init), as.logical(separated))

  if (is.null(address)) {
      stop("Error encountered when creating instance of type big.matrix")
  }

  x <- new("big.matrix", address=address)

  if (is.null(x)) {
      stop("Error encountered when creating instance of type big.matrix")
  }

  if (is.null(descriptorfile) && !anon.backing) {
      warning(paste("A descriptor file has not been specified.  ",
                    "A descriptor named ", backingfile,
                    ".desc will be created.", sep=''))
      descriptorfile <- paste(backingfile, ".desc", sep='' )
  }

  if (!anon.backing) {
    descriptorfilepath <- paste(backingpath, descriptorfile,
                                sep=.Platform$file.sep)
    if(binarydescriptor) {
        saveRDS(describe(x), file=descriptorfilepath)
    } else {
        dput(describe(x), descriptorfilepath)
    }
  }
  x
}


#' @rdname big.matrix
#' @export
setGeneric('as.big.matrix',
           function(x, type=NULL, separated=FALSE,
                    backingfile=NULL, backingpath=NULL,
                    descriptorfile=NULL, binarydescriptor=FALSE,
                    shared=options()$bigmemory.default.shared) {
             standardGeneric('as.big.matrix')
           })


#' @title Convert to base R matrix
#' @description Extract values from a \code{big.matrix} object
#' and convert to a base R matrix object
#' @param x A big.matrix object
#' @export
setMethod('as.matrix', signature(x='big.matrix'),
          function(x) return(x[,]))


#' @template as.big.matrix_methods_template
NULL


setMethod('as.big.matrix', signature(x='matrix'),
          function(x, type, separated, backingfile, backingpath, descriptorfile,
                   binarydescriptor, shared)
          {
              if (!is.numeric(x) && !is.raw(x)) {
                  warning("Casting to numeric type")
                  x <- matrix(as.numeric(x), nrow=nrow(x), dimnames=dimnames(x))
              }

              if (is.null(type)) type <- typeof(x)

              if (type %in% c("integer","double", "short", "char", "float",
                              "raw")) {
                  y <- big.matrix(nrow=nrow(x), ncol=ncol(x), type=type,
                                  init=NULL, dimnames=dimnames(x),
                                  separated=separated,
                                  backingfile=backingfile,
                                  backingpath=backingpath,
                                  descriptorfile=descriptorfile,
                                  binarydescriptor=binarydescriptor,
                                  shared=shared)
                  y[seq_len(nrow(x)),seq_len(ncol(x))] <- x
                  junk <- gc()
              } else stop('bigmemory: that type is not implemented.')
              return(y)
          })



setMethod('as.big.matrix', signature(x='data.frame'),
          function(x, type, separated, backingfile, backingpath, descriptorfile,
                   binarydescriptor, shared)
          {
              warning(paste("Coercing data.frame to matrix via factor",
                            "level numberings."))
              if (is.null(type)) type <- options()$bigmemory.default.type
              if (type %in% c("integer","double", "short", "char", "raw",
                              "float")) {
                  y <- big.matrix(nrow=nrow(x), ncol=ncol(x), type=type,
                                  init=NULL, dimnames=dimnames(x),
                                  separated=separated,
                                  backingfile=backingfile,
                                  backingpath=backingpath,
                                  descriptorfile=descriptorfile,
                                  binarydescriptor=binarydescriptor,
                                  shared=shared)
                  oldbtw <- options()$bigmemory.typecast.warning
                  options(bigmemory.typecast.warning=FALSE)
                  for (i in seq_len(ncol(x))) {
                      if (is.character(x[,i])) x[,i] <- factor(x[,i])
                      if (is.factor(x[,i])) x[,i] <- as.numeric(x[,i])
                      y[,i] <- x[,i]
                  }
                  options(bigmemory.typecast.warning=oldbtw)
                  junk <- gc()
              } else stop('bigmemory: that type is not implemented.')
              return(y)

          })



setMethod('as.big.matrix', signature(x='vector'),
          function(x, type, separated, backingfile, backingpath, descriptorfile,
                   binarydescriptor, shared) {
              if (!is.numeric(x)) {
                  warning("Casting to numeric type")
                  x <- as.numeric(x)
              }
              x <- matrix(x, length(x), 1)
              warning("Coercing vector to a single-column matrix.")
              return(as.big.matrix(x, type, separated, backingfile,
                                   backingpath, descriptorfile,
                                   binarydescriptor, shared))
          })


#' @rdname big.matrix
#' @export
setGeneric('is.big.matrix', function(x) standardGeneric('is.big.matrix'))

#' @rdname big.matrix
setMethod('is.big.matrix', signature(x='big.matrix'),
  function(x) return(TRUE))

#' @rdname big.matrix
setMethod('is.big.matrix', definition=function(x) return(FALSE))

colnames.bm <- function(x) {
  ret <- GetColumnNamesBM(x@address)
  if (length(ret)==0) return(NULL)
  return(ret)
}

rownames.bm <- function(x) {
  ret <- GetRowNamesBM(x@address)
  if (length(ret)==0) return(NULL)
  return(ret)
}

assign('colnames.bm<-',
  function(x, value) {
      checkReadOnly(x)
      if (is.character(value)) {
        if (any(value=="")) {
          stop("empty strings prohibited in column names")
        }
      } else {
        if (!is.null(value)) {
          value <- as.character(value)
          warning("column names coerced to character")
        }
      }
      if (!is.null(value) & length(value) != ncol(x))
        stop("length of 'colnames' not equal to array extent.")
      SetColumnNames(x@address, value)
      return(x)
  })

assign('rownames.bm<-',
  function(x,value) {
      checkReadOnly(x)
      if (is.character(value)) {
        if (any(value=="")) {
          stop("empty strings prohibited in row names")
        }
      } else {
        if (!is.null(value)) {
          value <- as.character(value)
          warning("row names coerced to character")
        }
      }
      if (length(value) != nrow(x) & !is.null(value))
        stop("length of 'rownames' not equal to array extent.")
      SetRowNames(x@address, value)
      return(x)
  })

#' @title The Number of Rows/Columns of a big.matrix
#' @description \code{nrow} and \code{ncol} return the number of
#' rows or columns present in a \code{big.matrix} object.
#' @param x A big.matrix object
#' @return An integer of length 1
#' @docType methods
#' @rdname ncol-methods
#' @export
setMethod('ncol', signature(x="big.matrix"),
  function(x) return(CGetNcol(x@address)))

#' @rdname ncol-methods
#' @export
setMethod('nrow', signature(x="big.matrix"),
  function(x) return(CGetNrow(x@address)))

#' @title Dimensions of a big.matrix object
#' @description Retrieve the dimensions of a \code{big.matrix} object
#' @param x A \code{big.matrix} object
#' @export
setMethod('dim', signature(x="big.matrix"),
  function(x) return(c(nrow(x), ncol(x))))

#' @title Length of a big.matrix object
#' @description Get the length of a \code{big.matrix} object
#' @param x A \code{big.matrix} object
#' @export
setMethod('length', signature(x="big.matrix"),
  function(x) return(prod(dim(x))))

GetElements.bm <- function(x, i, j, drop=TRUE) {
  if (!is.numeric(i) & !is.character(i) & !is.logical(i))
    stop("row indices must be numeric, logical, or character vectors.")
  if (!is.numeric(j) & !is.character(j) & !is.logical(j))
    stop("column indices must be numeric, logical, or character vectors.")
  if (is.character(i))
    if (is.null(rownames(x))) stop("row names do not exist.")
    else i <- mmap(i, rownames(x))
  if (is.character(j))
    if (is.null(colnames(x))) stop("column names do not exist.")
    else j <- mmap(j, colnames(x))
  if (is.logical(i)) {
    if (length(i) != nrow(x))
      stop("row vector length must match the number of rows of the matrix.")
    i <- which(i)
  }
  if (is.logical(j)) {
    if (length(j) != ncol(x))
      stop(paste("column vector length must match the number of",
                 "columns of the matrix."))
    j <- which(j)
  }

  tempi <- CCleanIndices(as.double(i), as.double(nrow(x)))
  if (is.null(tempi[[1]])) stop("Illegal row index usage in extraction.\n")
  if (tempi[[1]]) i <- tempi[[2]]
  tempj <- CCleanIndices(as.double(j), as.double(ncol(x)))
  if (is.null(tempj[[1]])) stop("Illegal column index usage in extraction.\n")
  if (tempj[[1]]) j <- tempj[[2]]

  retList <- GetMatrixElements(x@address, as.double(j), as.double(i))
  mat <- .addDimnames(retList, length(i), length(j), drop)
  return(mat)
}

# Function contributed by Peter Haverty at Genentech.
GetIndivElements.bm <- function(x,i) {
  # Check i
  if (is.logical(i)) {
    stop("Logical indices not allowed when subsetting by a matrix.")
  }
  if (ncol(i) != 2) {
    stop("When subsetting with a matrix, it must have two columns.")
  }
  if (is.character(i)) {
    if (is.null(rownames(x))) stop("row names do not exist.")
    if (is.null(colnames(x))) stop("column names do not exist.")
    i <- matrix(c(mmap(i[,1], rownames(x)), mmap(i[,2], colnames(x))), ncol=2)
  }
  tempi <- CCleanIndices(as.double(i[,1]), as.double(nrow(x)))
  if (is.null(tempi[[1]])) stop("Illegal row index usage in assignment.\n")
  if (tempi[[1]]) i[,1] <- tempi[[2]]
  tempj <- CCleanIndices(as.double(i[,2]), as.double(ncol(x)))
  if (is.null(tempj[[1]])) stop("Illegal column index usage in assignment.\n")
  if (tempj[[1]]) i[,2] <- tempj[[2]]

  return(GetIndivMatrixElements(x@address, as.double(i[,2]),
                                as.double(i[,1])))
}


# Function contributed by Charles Determan Jr.
GetIndivVectorElements.bm <- function(x,i) {
  # Check i
  if (is.logical(i)) {
    stop("Logical indices not allowed when subsetting by a matrix.")
  }
  if(any(i > length(x))){
    stop("indices out of range.")
  }
  return(GetIndivVectorMatrixElements(x@address, as.integer(i)))
}

GetCols.bm <- function(x, j, drop=TRUE) {
  if (!is.numeric(j) & !is.character(j) & !is.logical(j))
    stop("column indices must be numeric, logical, or character vectors.")
  if (is.character(j))
    if (is.null(colnames(x))) stop("column names do not exist.")
    else j <- mmap(j, colnames(x))
  if (is.logical(j)) {
    if (length(j) != ncol(x))
      stop(paste("column vector length must match the number of",
                 "columns of the matrix."))
    j <- which(j)
  }

  tempj <- CCleanIndices(as.double(j), as.double(ncol(x)))
  if (is.null(tempj[[1]])) stop("Illegal column index usage in extraction.\n")
  if (tempj[[1]]) j <- tempj[[2]]

  retList <- GetMatrixCols(x@address, as.double(j))
  mat <- .addDimnames(retList, nrow(x), length(j), drop)
  return(mat)
}

GetRows.bm <- function(x, i, drop=TRUE) {
  if (!is.numeric(i) & !is.character(i) & !is.logical(i))
    stop("row indices must be numeric, logical, or character vectors.")
  if (is.character(i))
    if (is.null(rownames(x))) stop("row names do not exist.")
    else i <- mmap(i, rownames(x))
  if (is.logical(i)) {
    if (length(i) != nrow(x))
      stop("row vector length must match the number of rows of the matrix.")
    i <- which(i)
  }
  tempi <- CCleanIndices(as.double(i), as.double(nrow(x)))
  if (is.null(tempi[[1]])) stop("Illegal row index usage in extraction.\n")
  if (tempi[[1]]) i <- tempi[[2]]

  retList <- GetMatrixRows(x@address, as.double(i))
  mat <- .addDimnames(retList, length(i), ncol(x), drop)
  return(mat)
}

GetAll.bm <- function(x, drop=TRUE) {
  retList <- GetMatrixAll(x@address)
  mat <- .addDimnames(retList, nrow(x), ncol(x), drop)
  return(mat)
}

#' @title Extract or Replace
#' @description Extract or replace big.matrix elements
#' @name Extract,big.matrix
#' @param x A \code{big.matrix object}
#' @param i Indices specifying the rows
#' @param j Indices specifying the columns
#' @param drop Logical indication if reduce to minimum dimensions
#' @param value typically an array-like R object of similar class
#' @param ... Additional arguments
#' @docType methods
#' @rdname extract-methods
#' @aliases [,big.matrix,ANY,ANY,missing-method
#' @aliases [<-,big.matrix,ANY,ANY,ANY-method
#' @export
setMethod("[",
  signature(x = "big.matrix", drop = "missing"),
  function(x, i, j, drop) return(GetElements.bm(x, i, j)))


#' @rdname extract-methods
#' @export
setMethod("[",
  signature(x = "big.matrix", drop = "logical"),
  function(x, i, j, drop) return(GetElements.bm(x, i, j, drop)))


#' @rdname extract-methods
#' @export
setMethod("[",
  signature(x = "big.matrix", i="missing", drop = "missing"),
  function(x, i, j, drop) return(GetCols.bm(x, j)))


#' @rdname extract-methods
#' @export
setMethod("[",
  signature(x = "big.matrix", i="missing", drop = "logical"),
  function(x, i, j, drop) return(GetCols.bm(x, j, drop)))


#' @rdname extract-methods
#' @export
setMethod("[",
  signature(x = "big.matrix", j="missing", drop = "missing"),
  function(x, i, j, ..., drop){
    # print(nargs())
    if(nargs() == 2){
      return(GetIndivVectorElements.bm(x,i))
    }else{
      return(GetRows.bm(x, i))
    }
  })


#' @rdname extract-methods
#' @export
setMethod("[",
  signature(x = "big.matrix", j="missing", drop = "logical"),
  function(x, i, j, drop) return(GetRows.bm(x, i, drop)))


#' @rdname extract-methods
#' @export
setMethod("[",
  signature(x = "big.matrix", i="missing", j="missing", drop = "missing"),
  function(x, i, j, drop) return(GetAll.bm(x)))


#' @rdname extract-methods
#' @export
setMethod("[",
  signature(x = "big.matrix", i="missing", j="missing", drop = "logical"),
  function(x, i, j, drop) return(GetAll.bm(x, drop)))

# Function contributed by Peter Haverty at Genentech.
#' @rdname extract-methods
#' @export
setMethod('[',
  signature(x = "big.matrix",i="matrix",j="missing",drop="missing"),
  function(x, i, j, drop) return(GetIndivElements.bm(x, i)))


#' @importFrom stats na.omit
SetElements.bm <- function(x, i, j, value) {
  checkReadOnly(x)
  if (!is.numeric(i) & !is.character(i) & !is.logical(i))
    stop("row indices must be numeric, logical, or character vectors.")
  if (!is.numeric(j) & !is.character(j) & !is.logical(j))
    stop("column indices must be numeric, logical, or character vectors.")
  if (is.character(i))
    if (is.null(rownames(x))) stop("row names do not exist.")
    else i <- mmap(i, rownames(x))
  if (is.character(j))
    if (is.null(colnames(x))) stop("column names do not exist.")
    else j <- mmap(j, colnames(x))
  if (is.logical(i)) {
    if (length(i) != nrow(x))
      stop("row vector length must match the number of rows of the matrix.")
    i <- which(i)
  }
  if (is.logical(j)) {
    if (length(j) != ncol(x))
      stop(paste("column vector length must match the number of",
                 "columns of the matrix."))
    j <- which(j)
  }

  tempi <- CCleanIndices(as.double(i), as.double(nrow(x)))
  if (is.null(tempi[[1]])) stop("Illegal row index usage in assignment.\n")
  if (tempi[[1]]) i <- tempi[[2]]
  tempj <- CCleanIndices(as.double(j), as.double(ncol(x)))
  if (is.null(tempj[[1]])) stop("Illegal column index usage in assignment.\n")
  if (tempj[[1]]) j <- tempj[[2]]

  if ( options()$bigmemory.typecast.warning &&
       ((typeof(value) == "double") && (typeof(x) != "double") ||
       (typeof(value) == "integer" && (typeof(x) != "double" &&
                                           typeof(x) != "float" &&
                                           typeof(x) != "integer")) ||
       (typeof(value) == "double" && (typeof(x) == "float")) ||
       (typeof(value) == "raw" && (typeof(x) != "raw"))
       ))
  {
    warning(paste0("Assignment will down cast from ", typeof(value), " to ",
                typeof(x), "\nHint: To remove this warning type:  ",
                "options(bigmemory.typecast.warning=FALSE)\n", sep=''))
  }

  totalts <- as.double(length(i)) * as.double(length(j))
  # If we are assigning from a matrix, make sure the dimensions agree.
  if (is.matrix(value))
  {
    if (ncol(value) != length(j) || nrow(value) != length(i))
    {
      stop("Matrix dimensions do not agree with big.matrix instance set size.")
    }
  } else if (length(value) != totalts) {
    # Otherwise, make sure we are assigning the correct number of things
    # (rep if necessary)
    numReps <- totalts / length(value)
    if (numReps != round(numReps))
    {
      stop("number of items to replace is not a multiple of replacement length")
    }
  }
  switch(typeof(x),
         'double' = {SetMatrixElements(x@address, as.double(j), as.double(i), as.double(value))},
         'float' = {SetMatrixElements(x@address, as.double(j), as.double(i), as.double(value))},
         #Don't convert raw before assigning them
         'raw' = {SetMatrixElements(x@address, as.double(j), as.double(i), value)},
         SetMatrixElements(x@address, as.double(j), as.double(i), to_int_checked(value))
  )
  x
}

SetIndivElements.bm <- function(x, i, value) {
  # Check i
  checkReadOnly(x)
  if (is.logical(i)) {
    stop("Logical indices not allowed when subsetting by a matrix.")
  }
  if (ncol(i) != 2) {
    stop("When subsetting with a matrix, it must have two columns.")
  }
  if (is.character(i)) {
    if (is.null(rownames(x))) stop("row names do not exist.")
    if (is.null(colnames(x))) stop("column names do not exist.")
    i <- matrix(c(mmap(i[,1], rownames(x)), mmap(i[,2], colnames(x))), ncol=2)
  }
  tempi <- CCleanIndices(as.double(i[,1]), as.double(nrow(x)))
  if (is.null(tempi[[1]])) stop("Illegal row index usage in assignment.\n")
  if (tempi[[1]]) i[,1] <- tempi[[2]]
  tempj <- CCleanIndices(as.double(i[,2]), as.double(ncol(x)))
  if (is.null(tempj[[1]])) stop("Illegal column index usage in assignment.\n")
  if (tempj[[1]]) i[,2] <- tempj[[2]]

  # Check value length, rep as necessary
  if (length(value) > nrow(i) || nrow(i) %% length(value) != 0) {
    stop("number of items to replace is not a multiple of replacement length")
  }
  if (length(value) < nrow(i)) {
    value <- rep(value, nrow(i) %/% length(value))
  }

  # Give typecast warning if necessary
  if ( options()$bigmemory.typecast.warning &&
       ((typeof(value) == "double") && (typeof(x) != "double") ||
       (typeof(value) == "integer" &&
        (typeof(x) != "double" && typeof(x) != "integer"))) ||
       (typeof(value) == "double" && (typeof(x) == "float")) ||
  		 (typeof(value) == "raw" && (typeof(x) != "raw"))) {
    warning(cat("Assignment will down cast from ", typeof(value), " to ",
                typeof(x), "\nHint: To remove this warning type:  ",
                "options(bigmemory.typecast.warning=FALSE)\n", sep=''))
  }

  switch(typeof(x),
    'double' = {SetIndivMatrixElements(x@address, as.double(i[,2]),
                                       as.double(i[,1]), as.double(value))},
    'float' = {SetIndivMatrixElements(x@address, as.double(i[,2]),
                                      as.double(i[,1]), as.single(value))},
    #Don't convert raw before assigning them
    'raw' = {SetIndivMatrixElements(x@address, as.double(i[,2]),
  																	as.double(i[,1]), value)},
     SetIndivMatrixElements(x@address, as.double(i[,2]),
                            as.double(i[,1]), as.integer(value)))
  x
}


# Function contributed by Charles Determan Jr.
SetIndivVectorElements.bm <- function(x, i, value) {
  # Check i
  if (is.logical(i)) {
    stop("Logical indices not allowed when subsetting by a matrix.")
  }
  if(any(i > length(x))){
    stop("indices out of range.")
  }

  if(length(value) > length(i)) {
    stop("value elements longer than indices")
  }

  if(length(value) < length(i)) {
    if(length(value) != 1){
      stop("value must be of length equal to 'i' or 1")
    }
  }

  if(length(value) == 1) {
    value <- rep(value, length(i))
  }

  SetIndivVectorMatrixElements(x@address, as.integer(i), value)

  x
}

#' @importFrom stats na.omit
SetCols.bm <- function(x, j, value)
{
  checkReadOnly(x)
  if (!is.numeric(j) & !is.character(j) & !is.logical(j))
    stop("column indices must be numeric, logical, or character vectors.")
  if (is.character(j))
    if (is.null(colnames(x))) stop("column names do not exist.")
    else j <- mmap(j, colnames(x))
  if (is.logical(j)) {
    if (length(j) != ncol(x))
      stop(paste("column vector length must match the number of",
                 "columns of the matrix."))
    j <- which(j)
  }

  tempj <- CCleanIndices(as.double(j), as.double(ncol(x)))
  if (is.null(tempj[[1]])) stop("Illegal column index usage in extraction.\n")
  if (tempj[[1]]) j <- tempj[[2]]

  if ( options()$bigmemory.typecast.warning &&
       ((typeof(value) == "double") && (typeof(x) != "double") ||
       (typeof(value) == "integer" &&
        (typeof(x) != "double" && typeof(x) != "integer")) ||
       (typeof(value) == "double" && (typeof(x) == "float"))) ||
  		 (typeof(value) == "raw" && (typeof(x) != "raw"))) {
    warning(cat("Assignment will down cast from ", typeof(value), " to ",
                typeof(x), "\nHint: To remove this warning type:  ",
                "options(bigmemory.typecast.warning=FALSE)\n", sep=''))
  }

  totalts <- as.double(nrow(x)) * as.double(length(j))
  # If we are assigning from a matrix, make sure the dimensions agree.
  if (is.matrix(value)) {
    if (ncol(value) != length(j) | nrow(value) != nrow(x)) {
      stop("Matrix dimensions do not agree with big.matrix instance set size.")
    }
  }
  else if (length(value) != totalts) {
    # Otherwise, make sure we are assigning the correct number of things
    # (rep if necessary)
    numReps <- totalts / length(value)
    if (numReps != round(numReps)) {
      stop(paste("number of items to replace is not a multiple of",
                 "replacement length"))
    }
  }
  if (typeof(x) != 'double') {
    integerVals <- na.omit(as.integer(value))
    if ( sum(integerVals == na.omit(as.integer(value))) !=
         length(integerVals) | is.factor(value)) {
      warning("non-integer (possibly Inf or -Inf) typecast to integer")
    }
  }

  switch(typeof(x),
    'double' = {SetMatrixCols(x@address, as.double(j), as.double(value))},
    'float' = {SetMatrixCols(x@address, as.double(j), as.single(value))},
  	#Don't convert raw before assigning them
  	'raw' = {SetMatrixCols(x@address, as.double(j), value)},
  	SetMatrixCols(x@address, as.double(j), as.integer(value)))

  x
}

#' @importFrom stats na.omit
SetRows.bm <- function(x, i, value) {
  checkReadOnly(x)
  if (!is.numeric(i) & !is.character(i) & !is.logical(i))
    stop("row indices must be numeric, logical, or character vectors.")
  if (is.character(i))
    if (is.null(rownames(x))) stop("row names do not exist.")
    else i <- mmap(i, rownames(x))
  if (is.logical(i)) {
    if (length(i) != nrow(x)) {
      stop("row vector length must match the number of rows of the matrix.")
    }
    i <- which(i)
  }

  tempi <- CCleanIndices(as.double(i), as.double(nrow(x)))
  if (is.null(tempi[[1]])) stop("Illegal row index usage in extraction.\n")
  if (tempi[[1]]) i <- tempi[[2]]

  if ( options()$bigmemory.typecast.warning &&
       ((typeof(value) == "double") && (typeof(x) != "double") ||
       (typeof(value) == "integer" &&
        (typeof(x) != "double" && typeof(x) != "integer"))  ||
       (typeof(value) == "double" && (typeof(x) == "float"))) ||
  		 (typeof(value) == "raw" && (typeof(x) != "raw"))) {
    warning(cat("Assignment will down cast from ", typeof(value), " to ",
                typeof(x), "\nHint: To remove this warning type:  ",
                "options(bigmemory.typecast.warning=FALSE)\n", sep=''))
  }

  # Note: i may be a mwhich statement in which case we _must_ ensure
  # that we disable read locking before it is evaluated or we will
  # have a race condition.  - Jay and Mike.

  totalts <- as.double(length(i)) * as.double(ncol(x))

  # If we are assigning from a matrix, make sure the dimensions agree.
  if (is.matrix(value)) {
    if (ncol(value) != ncol(x) | nrow(value) != length(i)) {
      stop("Matrix dimensions do not agree with big.matrix instance set size.")
    }
  }
  else if (length(value) != totalts) {
    # Otherwise, make sure we are assigning the correct number of things
    # (rep if necessary)
    numReps <- totalts / length(value)
    if (numReps != round(numReps))
    {
      stop(paste("number of items to replace is not a multiple of",
                 "replacement length"))
    }
  }
  if (typeof(x) != 'double') {
    integerVals <- na.omit(as.integer(value))
    if ( sum(integerVals == na.omit(as.integer(value))) !=
         length(integerVals) | is.factor(value)) {
      warning("non-integer (possibly Inf or -Inf) typecast to integer")
    }
  }

  switch(typeof(x),
    'double' = {SetMatrixRows(x@address, as.double(i), as.double(value))},
    'float' = {SetMatrixRows(x@address, as.double(i), as.single(value))},
  	#Don't convert raw before assigning them
  	'raw' = {SetMatrixRows(x@address, as.double(i), value)},
    SetMatrixRows(x@address, as.double(i), as.integer(value)))

  x
}

#' @importFrom stats na.omit
SetAll.bm <- function(x, value) {
  checkReadOnly(x)
  if ( options()$bigmemory.typecast.warning &&
       ((typeof(value) == "double") && (typeof(x) != "double") ||
       (typeof(value) == "integer" &&
        (typeof(x) != "double" && typeof(x) != "integer"))  ||
       (typeof(value) == "double" && (typeof(x) == "float"))) ||
  		 (typeof(value) == "raw" && (typeof(x) != "raw"))) {
    warning(cat("Assignment will down cast from ", typeof(value), " to ",
                typeof(x), "\nHint: To remove this warning type:  ",
                "options(bigmemory.typecast.warning=FALSE)\n", sep=''))
  }

  totalts <- as.double(nrow(x)) * as.double(ncol(x))
  # If we are assigning from a matrix, make sure the dimensions agree.
  if (is.matrix(value)) {
    if (ncol(value) != ncol(x) | nrow(value) != nrow(x)) {
      stop("Matrix dimensions do not agree with big.matrix instance set size.")
    }
  }
  else if (length(value) != totalts) {
    # Otherwise, make sure we are assigning the correct number of things
    # (rep if necessary)
    numReps <- totalts / length(value)
    if (numReps != round(numReps)) {
      stop(paste("number of items to replace is not a multiple of",
                 "replacement length"))
    }
  }
  if (typeof(x) != 'double')
  {
    integerVals <- na.omit(as.integer(value))
    if ( sum(integerVals == na.omit(as.integer(value))) !=
         length(integerVals) | is.factor(value)) {
      warning("non-integer (possibly Inf or -Inf) typecast to integer")
    }
  }

  switch(typeof(x),
    'double' = {SetMatrixAll(x@address, as.double(value))},
    'float' = {SetMatrixAll(x@address, as.single(value))},
  	#Don't convert raw before assigning them
  	'raw' = {SetMatrixAll(x@address, value)},
  	SetMatrixAll(x@address, as.integer(value)))

  x
}

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "numeric", j = "numeric"),
  function(x, i, j, value) return(SetElements.bm(x, i, j, value)))

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "numeric", j = "logical"),
  function(x, i, j, value) return(SetElements.bm(x, i, j, value)))

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "logical", j = "numeric"),
  function(x, i, j, value) return(SetElements.bm(x, i, j, value)))

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "logical", j = "logical"),
  function(x, i, j, value) return(SetElements.bm(x, i, j, value)))

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "logical", j = "character"),
  function(x, i, j, value) {
    if (any(duplicated(j))) {
      stop("Column names can't be duplicated.")
    }
    ms <- match(j, colnames(x))
    if (any(is.na(ms))) {
      stop("Column names don't appear in the big.matrix.")
    }
    return(SetElements.bm(x, i, ms, value))
  })

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "numeric", j = "character"),
  function(x, i, j, value) {
    if (any(duplicated(j))) {
      stop("Column names can't be duplicated.")
    }
    ms <- match(j, colnames(x))
    if (any(is.na(ms))) {
      stop("Column names don't appear in the big.matrix.")
    }
    return(SetElements.bm(x, i, ms, value))
  })

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "missing", j = "missing"),
  function(x, i, j, value){
    i <- seq(nrow(x))
    j <- seq(ncol(x))
    return(SetElements.bm(x, i, j, value))
  })

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i="missing", j = "numeric"),
  function(x, i, j, value) return(SetCols.bm(x, j, value)))

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i="missing", j = "logical"),
  function(x, i, j, value) return(SetCols.bm(x, j, value)))

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "numeric", j="missing", value = "numeric"),
  function(x, i, j, ..., value){

    if (nargs() == 3){
      SetIndivVectorElements.bm(x, i, value)
    } else {
      SetRows.bm(x, i, value)
    }
  })


#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "logical", j="missing", value = "numeric"),
  function(x, i, j, ..., value){

    if (nargs() == 3) {
      SetIndivVectorElements.bm(x, i, value)
    } else {
      SetRows.bm(x, i, value)
    }
  })

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "numeric", j="missing", value = "matrix"),
  function(x, i, j, ..., value){

    if (nargs() == 3) {
      SetIndivVectorElements.bm(x, i, value)
    } else {
      SetRows.bm(x, i, value)
    }
  })

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i = "logical", j="missing", value = "matrix"),
  function(x, i, j, ..., value){

    if (nargs() == 3) {
      SetIndivVectorElements.bm(x, i, value)
    } else {
      SetRows.bm(x, i, value)
    }
  })

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x="big.matrix", i="character", j="character"),
  function(x, i, j, value) return(SetElements.bm(x, i, j, value)))

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x="big.matrix", i="missing", j="character"),
  function(x, j, value) return(SetCols.bm(x, j, value)))

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x="big.matrix", i="character", j="missing"),
  function(x, i, value) return(SetRows.bm(x, i, value)))

#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix", i="missing", j="missing", value = "numeric"),
  function(x, i, j, value) SetAll.bm(x, value))

# Function contributed by Peter Haverty at Genentech.
#' @rdname extract-methods
#' @export
setMethod('[<-',
  signature(x = "big.matrix",i="matrix",j="missing", value = "numeric"),
  function(x, i, j, value) SetIndivElements.bm(x, i, value))

#' @title The Type of a big.matrix Object
#' @description \code{typeof} returns the storage type of a
#' \code{big.matrix} object
#' @param x A \code{big.matrix} object
#' @export
setMethod('typeof', signature(x="big.matrix"),
  function(x) {
    GetTypeString(x@address)
  })


#' @title Check if Float
#' @description Check to see if the elements of a big.matrix object are floats.
#' @param x An object to be evaluated if float
#' @export
setGeneric('is.float', function(x) standardGeneric('is.float'))

#' @title Is Float?
#' @description Check if R numeric value has float flag
#' @param x A numeric value
setMethod('is.float', signature(x='numeric'),
  function(x){
    if (is.null(attr(x, 'Csingle'))) {
      FALSE
    } else {
      bool <- attr(x, 'Csingle')
      bool
    }
  })

#' @title Return First or Last Part of a big.matrix Object
#' @description Returns the first or last parts of a \code{big.matrix}
#' object.
#' @param x A big.matrix object
#' @param n A single integer for the number of rows to return
#' @docType methods
#' @rdname head-methods
#' @export
setMethod('head', signature(x="big.matrix"),
  function(x, n = 6) {
    n <- min(as.integer(n), nrow(x))
    if ( n < 1 | n > nrow(x) ) {
      stop("n must be between 1 and nrow(x)")
    }
    return(x[seq_len(n),])
  })


#' @rdname head-methods
#' @export
setMethod('tail', signature(x="big.matrix"),
  function(x, n = 6) {
    n <- min(as.integer(n), nrow(x))
    if ( n < 1 | n > nrow(x) ) {
      stop("n must be between 1 and nrow(x)")
    }
    return(x[(nrow(x)-n+1):nrow(x),])
  })

#' @title Print Values
#' @description \code{print} will print out the elements within
#' a \code{big.matrix} object.
#' @note By default, this will only return the \code{head} of a big.matrix
#' to prevent console overflow.  If you turn off the bigmemory.print.warning
#' option then it will convert to a base R matrix and print all elements.
#' @param x A \code{big.matrix} object
#' @export
setMethod('print', signature(x='big.matrix'),
  function(x) {
    if (options()$bigmemory.print.warning==TRUE)
    {
      cat("Warning: This is not advised.  Here is the head of the matrix:\n")
      print(head(x))
    }
    else
    {
      # Should change this to a C print function, unfortunately, for proper
      # formatting, this means we would also have to pass the terminal
      # width.
      print(x[,])
    }
  })

###################################################################
# mwhich()
#
# x big.matrix
# cols  is.numeric or is.character
# vals  list of scalar or 2-vectors otherwise
# comps could be missing, in which case we'll fill in 'eq' in signature,
#       a list of comparisons matching dim of associated vals component

#' @template mwhich_template
#' @export
setGeneric('mwhich', function(x, cols, vals, comps, op = 'AND')
  standardGeneric('mwhich'))

# add mwhich-methods roxygen
# setting to NULL avoids the redundant usage statements
#' @template mwhich_methods_template
NULL

setMethod('mwhich',
  signature(x='big.matrix', op='character'),
  function(x, cols, vals, comps, op) {
    return(mwhich.internal(x, cols, vals, comps, op, MWhichBigMatrix))
  })

# @rdname mwhich-methods
setMethod('mwhich',
  signature(x='matrix', op='character'),
  function(x, cols, vals, comps, op)
  {
    if (is.integer(x)) {
      mwhich.internal(x, cols, vals, comps, op, MWhichRIntMatrix)
    } else if (is.numeric(x)) {
      mwhich.internal(x, cols, vals, comps, op, MWhichRNumericMatrix)
    } else {
      stop("Unsupported matrix type given to mwhich")
    }
  })

# @rdname mwhich-methods
setMethod('mwhich',
  signature(x='big.matrix', op='missing'),
  function(x, cols, vals, comps)
    return(mwhich.internal(x, cols, vals, comps, op='AND',
                           whichFuncName=MWhichBigMatrix)))

# @rdname mwhich-methods
setMethod('mwhich',
  signature(x='matrix', op='missing'),
  function(x, cols, vals, comps)
  {
    if (is.integer(x))
      return(mwhich.internal(x, cols, vals, comps, op='AND',
                             whichFuncName=MWhichRIntMatrix))
    if (is.numeric(x))
      return(mwhich.internal(x, cols, vals, comps, op='AND',
                             whichFuncName=MWhichRNumericMatrix))
    stop("Unsupported matrix type given to mwhich")
  })

mwhich.internal <- function(x, cols, vals, comps, op, whichFuncName)
{
  cols <- cleanupcols(cols, ncol(x), colnames(x))
  if (length(setdiff(cols, seq_len(ncol(x)))) > 0)
    stop('Invalid column(s) in which()')

  # if vals or comps are not lists but are length 1 or 2, make them
  # trivial lists.
  if ( !is.list(vals) &
       (length(vals)==1 || length(vals)==2) ) {
    vals <- list(vals)
  } else {
    if (!is.list(vals)) stop('vals should be a list')
  }
  if ( !is.list(comps) &
       (length(comps)==1 || length(comps)==2)) {
    comps <- list(comps)
  } else {
    if (!is.list(comps)) stop('comps should be a list')
  }

  # Replicate vals or comps if appropriate.
  if (length(cols)!=length(vals)) {
    if (length(vals)==1) {
      vals <- data.frame(matrix(unlist(vals), length(vals), length(cols)))
    } else stop('length(vals) must be 1 or length(cols)')
  }
  if (length(cols)!=length(comps)) {
    if (length(comps)==1) {
      comps <- data.frame(matrix(unlist(comps), length(comps), length(cols)),
                          stringsAsFactors=FALSE)
    } else stop('length(comps) must be 1 or length(cols)')
  }
  if (length(comps)!=length(vals))
    stop('length of comps must equal length of vals')
  if (any(!unlist(lapply(comps, is.character))) ||
      any(!(unlist(comps) %in% c('eq', 'neq', 'le', 'lt', 'ge', 'gt')))) {
    stop('comps must contain eq, neq, le, lt, ge, or gt')
  }

  testCol <- cols
  opVal <- 0
  if (op == 'OR') opVal <- 1
  minVal <- rep(NA, length(cols))
  maxVal <- rep(NA, length(cols))
  chkmin <- rep(0, length(cols))
  chkmax <- rep(0, length(cols))

  for (i in seq_len(length(cols))) {

    if (length(vals[[i]])==1) {
      # Here, we have the easy comparisons.
      if (is.na(vals[[i]]) && (comps[[i]]!='eq' && comps[[i]]!='neq'))
        stop('NA comparison limited to eq and neq, not le, lt, gt, or ge')
      if (length(comps[[i]])==1) {
        if (comps[[i]]=='eq' || comps[[i]]=='neq') {
          minVal[i] <- vals[[i]]
          maxVal[i] <- vals[[i]]
        }
        if (comps[[i]]=='neq') {
          chkmin[i] <- -1
          chkmax[i] <- -1            # Not used, but....
        }
        if (comps[[i]]=='ge' || comps[[i]]=='gt') {
          minVal[i] <- vals[[i]]
          maxVal[i] <- Inf
          if (comps[[i]]=='gt') chkmin[i] <- 1
        }
        if (comps[[i]]=='le' || comps[[i]]=='lt') {
          minVal[i] <- -Inf
          maxVal[i] <- vals[[i]]
          if (comps[[i]]=='lt') chkmax[i] <- 1
        }
      } else stop('vals/comps must be componentwise of same dimension')
    } else {
      # Here, we have two vals and two comps
      if (any(is.na(vals[[i]]))) stop('NAs not allowed in interval comparison')
      minVal[i] <- vals[[i]][1]
      maxVal[i] <- vals[[i]][2]
      if (comps[[i]][1]=='gt') chkmin[i] <- 1
      if (comps[[i]][2]=='lt') chkmax[i] <- 1
      if (comps[[i]][1]!='gt' && comps[[i]][1]!='ge')
        stop('invalid comparison of lower bound')
      if (comps[[i]][2]!='lt' && comps[[i]][2]!='le')
        stop('invalid comparison of upper bound')
    }

  } # End of the for loop

  ##### The new C function has new vectors chkmin and chkmax;
  ##### the value 0 indicates comparison with equality,
  ##### the value 1 indicates a strict inequality,
  ##### the value -1 indicates a 'neq' check;
  ##### if is.na checking is required, only the minVal needs to be
  ##### used, with chkmin = 0 being is.na and chkmin = 1 being !is.na.

  ret <- NULL
  if (is.big.matrix(x)) {
    ret <- whichFuncName(x@address, as.double(testCol),
                as.double(minVal), as.double(maxVal),
                as.integer(chkmin), as.integer(chkmax), as.integer(opVal))
  } else {
    ret <- whichFuncName(x, nrow(x),
                as.double(testCol),
                as.double(minVal), as.double(maxVal),
                as.integer(chkmin), as.integer(chkmax), as.integer(opVal))
  }
  ret
}


#' @title Dimnames of a big.matrix Object
#' @description Retrieve or set the dimnames of an object
#' @param x A big.matrix object
#' @param value A possible value for \code{dimnames(x)}
#' @docType methods
#' @rdname dimnames-methods
#' @export
setMethod('dimnames', signature(x = "big.matrix"),
  function(x) return(list(rownames.bm(x), colnames.bm(x))))


#' @rdname dimnames-methods
#' @export
setMethod('dimnames<-', signature(x = "big.matrix", value='list'),
  function(x, value) {
    if (options()$bigmemory.allow.dimnames) {
      rownames.bm(x) <- value[[1]]
      colnames.bm(x) <- value[[2]]
    } else {
      stop(paste("Changing dimnames is not allowed; to override, please set",
                 "options(bigmemory.allow.dimnames=TRUE)."))
    }
    return(x)
  })


#' @template write.big.matrix_template
#' @export
setGeneric('write.big.matrix',
           function(x, filename, row.names=FALSE, col.names=FALSE, sep=",")
               standardGeneric('write.big.matrix'))

#' @rdname write.big.matrix
setMethod('write.big.matrix', signature(x='big.matrix',filename='character'),
          function(x, filename, row.names, col.names, sep)
          {
            if (is.character(row.names))
                stop("You must set the row names before writing.\n")
            if (is.character(col.names))
                stop("You must set the column names before writing.\n")
            if (row.names & !HasRowColNames(x@address)[1]) {
                row.names <- FALSE
                warning(paste("No row names exist, overriding your",
                              "row.names option.\n"))
            }
            if (col.names & !HasRowColNames(x@address)[2]) {
                col.names <- FALSE
                warning(paste("No column names exist, overriding your",
                              "col.names option.\n"))
            }
            WriteMatrix(x@address, filename, as.logical(row.names),
                        as.logical(col.names), sep)
            invisible(NULL)
          })


#' @rdname write.big.matrix
#' @export
setGeneric('read.big.matrix',
  function(filename, sep=',', header=FALSE, col.names=NULL, row.names=NULL,
           has.row.names=FALSE, ignore.row.names=FALSE, type=NA, skip=0,
           separated=FALSE, backingfile=NULL, backingpath=NULL,
           descriptorfile=NULL, binarydescriptor=FALSE, extraCols=NULL,
           shared=options()$bigmemory.default.shared)
  standardGeneric('read.big.matrix'))

#' @importFrom stats na.omit
#' @rdname write.big.matrix
setMethod('read.big.matrix', signature(filename='character'),
  function(filename, sep, header, col.names, row.names, has.row.names,
           ignore.row.names, type, skip, separated, backingfile, backingpath,
           descriptorfile, binarydescriptor, extraCols,
           shared=options()$bigmemory.default.shared) {

    if (!is.logical(header))
      stop("header argument must be logical")
    if (is.logical(col.names) || is.logical(row.names))
      stop(paste("row.names and col.names, if used, must only be vectors",
                 "of names (not logicals)."))
    if ( (header || is.character(col.names)) && is.numeric(extraCols) ) {
      stop(paste("When column names are specified, extraCols must be the names",
                 "of the extra columns."))
    }
    if (!header && is.null(col.names) && is.character(extraCols))
      stop(paste("No header and no column names were specified, so extraCols",
           "must be an integer."))
    if (!file.exists(filename))
      stop(paste("The file", filename, "could not be found"))
    headerOffset <- as.numeric(header)
    colNames <- NULL
    if (header) {
      colNames <- unlist(strsplit(
        scan(filename, what='character', skip=skip, nlines=1, sep="\n",
             quiet=TRUE), split=sep))
      colNames <- gsub("\"", "", colNames, perl=TRUE)
      colNames <- gsub("\'", "", colNames, perl=TRUE)
      if (is.na(colNames[1])) colNames <- colNames[-1]
      if (is.character(col.names)) {
        warning("Using supplied column names and skipping the header row.\n")
        colNames <- col.names
      } else {
        if (!is.null(col.names)) {
          stop(paste("Invalid header/col.names usage (col.names must be",
                     "a vector of names if used).\n"))
        }
      }
    } else {
      if (is.character(col.names)) colNames <- col.names
    }

    # Get the first line of data
    firstLine <- scan(filename, what='character', skip=(skip+headerOffset),
      nlines=1, sep="\n", quiet=TRUE)
    firstLineVals <- unlist(strsplit(firstLine, split=sep))
    numFields <- length(firstLineVals)
    firstLineVals[firstLineVals=="NA"] <- NA
    if (length(firstLineVals) < numFields) {
      firstLineVals <- c(firstLineVals, NA)
    }

    # At this point, we assume there are length(colNames) columns of data if
    # available, otherwise, figure it out.
    if (!is.null(colNames)) numCols <- length(colNames)
    else {
      numCols <- length(firstLineVals) - has.row.names
    }

    if (length(firstLineVals) - has.row.names != numCols)
      stop("Dimension mismatch between header row and first data row.\n")

    rowNames <- NULL
    if (!is.null(row.names)) {
      if (is.character(row.names)) {
        rowNames <- row.names
        ignore.row.names <- TRUE
      } else {
        stop("Invalid row.names (must be a vector of names if used).\n")
      }
    }

    if (is.na(type)) {
      type <- 'double'
      if (has.row.names) firstLineVals <- firstLineVals[-1]
      if (sum(na.omit(as.integer(firstLineVals)) ==
              na.omit(as.double(firstLineVals))) ==
            numCols ) {
        type <- 'integer'
      }
      warning(paste("Because type was not specified, we chose", type,
                    "based on the first line of data."))
    }

    lineCount <- CCountLines(filename) - skip - headerOffset
    numRows <- lineCount
    createCols <- numCols
    if (is.numeric(extraCols)) createCols <- createCols + extraCols
    if (is.character(extraCols)) {
      createCols <- createCols + length(extraCols)
      colNames <- c(colNames, extraCols)
    }

    bigMat <- big.matrix(nrow=numRows, ncol=createCols, type=type,
                         dimnames=list(rowNames, colNames), init=NULL,
                         separated=separated, backingfile=backingfile,
                         backingpath=backingpath,
                         descriptorfile=descriptorfile,
                         binarydescriptor=binarydescriptor,
                         shared=options()$bigmemory.default.shared)

    # has.row.names indicates whether or not there are row names;
    # we take ignore.row.names from the user, but pass (essentially)
    # use.row.names (which is !ignore.row.names) to C:
    ReadMatrix(
          as.character(filename),
          bigMat@address,
          as.double(skip+headerOffset),
          as.double(numRows),
          as.double(numCols),
          as.character(sep),
          as.logical(has.row.names),
          as.logical(!ignore.row.names))

    bigMat
  })


#' @rdname big.matrix
#' @export
setGeneric('is.separated', function(x) standardGeneric('is.separated'))

#' @rdname big.matrix
setMethod('is.separated', signature(x='big.matrix'),
  function(x) return(IsSeparated(x@address)))

cleanupcols <- function(cols=NULL, nc=NULL, colnames=NULL) {
  if (is.null(cols)) cols <- 1:nc
  else {
    if (!is.numeric(cols) & !is.character(cols) & !is.logical(cols))
      stop("column indices must be numeric, logical, or character vectors.")
    if (is.character(cols))
      if (is.null(colnames)) stop("column names do not exist.")
      else cols <- mmap(cols, colnames)
    if (is.logical(cols)) {
      if (length(cols) != nc)
        stop(paste("column vector length must match the number of",
                   "columns of the matrix."))
      cols <- which(cols)
    }
    tempj <- CCleanIndices(as.double(cols), as.double(nc))
    if (is.null(tempj[[1]])) stop("Illegal column index usage in extraction.\n")
    if (tempj[[1]]) cols <- tempj[[2]]
  }
  return(cols)
}

cleanuprows <- function(rows=NULL, nr=NULL, rownames=NULL) {
  if (is.null(rows)) rows <- 1:nr
  else {
    if (!is.numeric(rows) & !is.character(rows) & !is.logical(rows))
      stop("column indices must be numeric, logical, or character vectors.")
    if (is.character(rows))
      if (is.null(rownames)) stop("row names do not exist.")
      else rows <- mmap(rows, rownames)
    if (is.logical(rows)) {
      if (length(rows) != nr)
        stop(paste("row vector length must match the number of",
                   "rows of the matrix."))
      rows <- which(rows)
    }
    tempj <- CCleanIndices(as.double(rows), as.double(nr))
    if (is.null(tempj[[1]])) stop("Illegal row index usage in extraction.\n")
    if (tempj[[1]]) rows <- tempj[[2]]
  }
  return(rows)
}


#' @template deepcopy_template
#' @export
deepcopy <- function(x, cols=NULL, rows=NULL,
                     y=NULL, type=NULL, separated=NULL,
                     backingfile=NULL, backingpath=NULL,
                     descriptorfile=NULL, binarydescriptor=FALSE,
                     shared=options()$bigmemory.default.shared)
{
  cols <- cleanupcols(cols, ncol(x), colnames(x))
  rows <- cleanuprows(rows, nrow(x), rownames(x))
  if (nrow(x) > 2^31-1)
    stop(paste("Too many rows to copy at this point in time;",
               "this may be fixed in the future."))
  if (is.null(type)) type <- typeof(x)
  if (is.big.matrix(x)) {
    if (is.null(separated)) separated <- is.separated(x)
  } else {
    separated <- FALSE
  }
  if (is.null(y)) {
    y <- big.matrix(nrow=length(rows), ncol=length(cols), type=type, init=NULL,
                  dimnames=dimnames(x), separated=separated,
                  backingfile=backingfile, backingpath=backingpath,
                  descriptorfile=descriptorfile,
                  binarydescriptor=binarydescriptor, shared)
  }
  if (is.big.matrix(x) && is.big.matrix(y)) {
    CDeepCopy(x@address, y@address, as.double(rows), as.double(cols),
              getOption("bigmemory.typecast.warning"))
  } else {
    for (i in seq_len(length(cols))) y[,i] <- x[rows,cols[i]]
  }

  return(y)
}

# Following the R convention we are going to assume Unix directory
# separators '/' as opposed to the Windows convention '\'.

#' @rdname sub.big.matrix
#' @export
setGeneric('is.sub.big.matrix', function(x)
	standardGeneric('is.sub.big.matrix'))

#' @rdname sub.big.matrix
setMethod('is.sub.big.matrix', signature(x='big.matrix'),
  function(x) return(CIsSubMatrix(x@address)) )

# For now a submatrix only goes over a range of columns and a range
# of row.  This could be made more sophiticated but it would probably
# take a lot of work.

#' @template sub.big.matrix_template
#' @export
setGeneric('sub.big.matrix', function(x, firstRow=1, lastRow=NULL,
  firstCol=1, lastCol=NULL, backingpath=NULL) standardGeneric('sub.big.matrix'))


#' @rdname sub.big.matrix
setMethod('sub.big.matrix', signature(x='big.matrix'),
  function(x, firstRow, lastRow, firstCol, lastCol, backingpath)
  {
    return(sub.big.matrix(describe(x), firstRow, lastRow, firstCol, lastCol,
           backingpath))
  })

#' @title Retrieve a big.matrix "view"
#' @rdname sub.big.matrix
#' @param x A descriptor object
#' @param firstRow the first row of the submatrix
#' @param lastRow the last row of the submatrix if not NULL
#' @param firstCol the first column of the submatrix
#' @param lastCol of the submatrix if not NULL
#' @param backingpath required path to the filebacked object, if applicable
setMethod('sub.big.matrix', signature(x='big.matrix.descriptor'),
  function( x, firstRow, lastRow, firstCol, lastCol, backingpath) {
    rowOffset <- firstRow-1
    colOffset <- firstCol-1
    rbm <- attach.resource(x, path=backingpath)
    if (is.null(lastRow)) lastRow <- nrow(rbm)
    if (is.null(lastCol)) lastCol <- ncol(rbm)
    numCols <- lastCol-firstCol+1
    numRows <- lastRow-firstRow+1
    if (colOffset < 0 || rowOffset < 0 || numCols < 1 || numRows < 1 ||
        colOffset+numCols > ncol(rbm) || rowOffset+numRows > nrow(rbm))
    {
      rm(rbm)
      stop(paste("A sub.big.matrix object could not be created",
                 "with the specified parameters"))
    }
    SetRowOffsetInfo(rbm@address,
          as.double(rowOffset + GetRowOffset(rbm@address)),
          as.double(numRows) )
    SetColumnOffsetInfo(rbm@address,
          as.double(colOffset + GetColOffset(rbm@address)),
          as.double(numCols))
    return(rbm)
  })


setMethod('description', signature(x='big.matrix.descriptor'),
  function(x) return(x@description))

DescribeBigMatrix <- function(x) {
  if (!is.filebacked(x)) {
    if (is.shared(x)) {
      list(sharedType = 'SharedMemory',
           sharedName = shared.name(x),
           totalRows = GetTotalRows(x@address),
           totalCols = GetTotalColumns(x@address),
           rowOffset = GetRowOffset(x@address),
           colOffset = GetColOffset(x@address),
           nrow=nrow(x), ncol=ncol(x),
           rowNames=rownames(x),
           colNames=colnames(x),
           type=typeof(x),
           separated=is.separated(x))
    } else {
      stop("you can't describe a non-shared big.matrix.")
    }
  } else {
    list(sharedType = 'FileBacked',
         filename = file.name(x),
         dirname = format_path(dir.name(x)), # need extra '/' on Windows
         totalRows = GetTotalRows(x@address),
         totalCols = GetTotalColumns(x@address),
         rowOffset = GetRowOffset(x@address),
         colOffset = GetColOffset(x@address),
         nrow=nrow(x), ncol=ncol(x),
         rowNames=rownames(x),
         colNames=colnames(x),
         type=typeof(x),
         separated=is.separated(x))
  }
}


#' @template attach.big.matrix_template
# @rdname attach.big.matrix
#' @export
attach.big.matrix <- function(obj, ...) {
  back <- list(...)[['backingpath']]
  if (is.null(back)) {
    attach.resource(obj, ...)
  } else {
    attach.resource(obj, path = back, ...)
  }
}

#' @rdname big.matrix.descriptor-class
#' @param obj The filename of the descriptor for a filebacked matrix,
#' assumed to be in the directory specified
#' @param ... possibly \code{path} which gives the path where the descriptor
#' and/or filebacking can be found.
#' @export
setMethod('attach.resource', signature(obj = 'character'),
  function(obj, ...) {
    path <- list(...)[['path']]

    if (is.null(path) || path == "") { # unspecified path extra argument
      fileWithPath <- path.expand(obj)
    } else {
      if (dirname(obj) != ".") { # path also specified in obj
        warning(paste("Two paths were specified in attach.resource.",
                      "The one associated with the file will be used.",
                      sep="\n"))
        fileWithPath <- path.expand(obj)
      } else {
        fileWithPath <- path.expand(file.path(path, obj))
      }
    }

    if (!file.exists(fileWithPath))
      stop( paste("The file", fileWithPath, "could not be found") )
    if (dir.exists(fileWithPath))
      stop( paste(fileWithPath, "is a directory") )

    info <- tryCatch(readRDS(fileWithPath),
                     error = function(er) dget(fileWithPath))
    if (info@description$sharedType == "FileBacked") {
      info@description$dirname <- format_path(dirname(fileWithPath))
    }

    attach.resource(info, path = NULL, ...)
  })

#' @rdname big.matrix.descriptor-class
#' @export
setMethod('attach.resource', signature(obj='big.matrix.descriptor'),
  function(obj, ...) {
    # path <- list(...)[['path']]
    info <- description(obj)
    typeLength <- NULL
    if (info$type == 'char') typeLength <- 1
    if (info$type == 'short') typeLength <- 2
    if (info$type == 'integer') typeLength <- 4
    if (info$type == 'float') typeLength <- 6
    if (info$type == 'double') typeLength <- 8
    if (info$type == 'raw' ) typeLength <- 3

    if (is.null(typeLength))
      stop('invalid type')

    readonly <- list(...)[['readonly']]
    readOnly <- `if`(is.null(readonly), FALSE, readonly)
    if (!is.logical(readOnly)) {
      stop("The readOnly argument must be of type logical")
    }

    if (info$sharedType == 'SharedMemory') {
      address <- CAttachSharedBigMatrix(as.character(info$sharedName),
        as.double(info$totalRows),
        as.double(info$totalCols),
        as.character(info$rowNames),
        as.character(info$colNames),
        as.integer(typeLength),
        as.logical(info$separated),
        as.logical(readOnly))
    } else {
      file <- file.path(info$dirname, info$filename)
      if (!info$separated) {
        if (!file.exists(file))
        {
          stop(paste("The backing file", file, "could not be found"))
        }
      } else {
        # It's separated and we need to check for each column.
        fn <- paste0(file, "_column_", 1:info$ncol - 1)
        noexists <- which(!file.exists(fn))
        if (length(noexists)) # report the first non-existing
          stop(paste("The backing file", fn[noexists[1]],
                     "could not be found"))
      }
      address <- CAttachFileBackedBigMatrix(
        as.character(info$filename),
        as.character(info$dirname),
        as.double(info$totalRows),
        as.double(info$totalCols),
        as.character(info$rowNames),
        as.character(info$colNames),
        as.integer(typeLength),
        as.logical(info$separated),
        as.logical(readOnly))
    }
    if (!is.null(address)) {
      SetRowOffsetInfo(address, info$rowOffset, info$nrow)
      SetColumnOffsetInfo(address, info$colOffset, info$ncol)
      ret <- new('big.matrix', address=address)
      # If the user did not specify read-only but the big matrix could
      # only be opened read-only then issue a warning.
      if (readOnly != is.readonly(ret)) {
        warning("big.matrix object could only be opened read-only.")
      }
    } else {
      stop("Fatal error in attach: big.matrix could not be attached.")
    }
    return(ret)
  })


#' @rdname big.matrix
#' @export
setGeneric('is.filebacked', function(x) standardGeneric('is.filebacked'))

#' @rdname big.matrix
setMethod('is.filebacked', signature(x='big.matrix'),
  function(x) return(IsFileBackedBigMatrix(x@address)))

#' @rdname big.matrix
#' @export
setGeneric('shared.name', function(x) standardGeneric('shared.name'))

#' @rdname big.matrix
setMethod('shared.name', signature(x='big.matrix'),
  function(x) return(SharedName(x@address)))

#' @rdname big.matrix
#' @export
setGeneric('file.name', function(x) standardGeneric('file.name'))

#' @rdname big.matrix
setMethod('file.name', signature(x='big.matrix'),
  function(x) {
    if (!is.filebacked(x)) {
      stop("The argument is not a file backed big.matrix.")
    }
    return(FileName(x@address))
  })

#' @rdname big.matrix
#' @export
setGeneric('dir.name', function(x) standardGeneric('dir.name'))

#' @rdname big.matrix
setMethod('dir.name', signature(x='big.matrix'),
          function(x) {
            if (!is.filebacked(x)) {
              stop("The argument is not a file backed big.matrix.")
            }
            return(DirName(x@address))
          })



#' @template flush_template
#' @export
setGeneric('flush', function(con) standardGeneric('flush'))

#' @rdname flush-methods
setMethod('flush', signature(con='big.matrix'),
  function(con) {
    if (!is.filebacked(con)) {
      warning("You cannot call flush on a non-filebacked big.matrix")
      return(invisible(TRUE))
    }
    return(invisible(Flush(con@address)))
  })


#' @rdname big.matrix
#' @export
setGeneric('is.shared', function(x) standardGeneric('is.shared'))

#' @rdname big.matrix
setMethod('is.shared', signature(x='big.matrix'),
  function(x) return(IsShared(x@address)))

#' @template morder_template
#' @export
morder <- function(x, cols, na.last=TRUE, decreasing = FALSE) {
  if (is.character(cols)) cols <- mmap( cols, colnames(x) )
  if (sum(cols > ncol(x)) > 0 | sum(cols < 1) > 0 | sum(is.na(cols) > 0))
  {
    stop("Bad column indices.")
  }

  switch(class(x)[1],
    "big.matrix"=OrderBigMatrix(x@address, as.double(cols),
                                  as.integer(na.last), as.logical(decreasing) ),
    "matrix" = switch(typeof(x),
      'integer'=OrderRIntMatrix(x, nrow(x), as.double(cols),
                                as.integer(na.last),
                                as.logical(decreasing) ),
      'double'=OrderRNumericMatrix(x, nrow(x), as.double(cols),
                                   as.integer(na.last),
                                   as.logical(decreasing) ),
      stop("Unsupported matrix value type.")),
    stop("unsupported matrix type")
  )
}

#' @rdname morder
#' @export
morderCols <- function(x, rows, na.last=TRUE, decreasing = FALSE) {
  if (is.character(rows)) rows <- mmap( rows, rownames(x) )

  if (sum(rows > nrow(x)) > 0 | sum(rows < 1) > 0 | sum(is.na(rows) > 0)) {
    stop("Bad row indices.")
  }

  switch(class(x)[1],
    "big.matrix"=OrderBigMatrixCols(x@address, as.double(rows),
                                    as.integer(na.last),
                                    as.logical(decreasing) ),
    "matrix"=switch(typeof(x),
      'integer'=OrderRIntMatrixCols(x, nrow(x), ncol(x),
                                    as.double(rows),
                                    as.integer(na.last),
                                    as.logical(decreasing) ),
      'double'=OrderRNumericMatrixCols(x, nrow(x), ncol(x),
                                       as.double(rows),
                                       as.integer(na.last),
                                       as.logical(decreasing) ),
       'raw' = OrderRIntMatrixCols(x, nrow(x), ncol(x), as.double(rows),
                                   as.integer(na.last),
                                   as.logical(decreasing) ),
        stop("Unsupported matrix value type.")),
    stop("unsupported matrix type"))
}

#' @rdname morder
#' @export
mpermute <- function(x, order=NULL, cols=NULL, allow.duplicates=FALSE, ...)
{
  if (is.null(order) && is.null(cols))
    stop("You must specify either order or cols.")

  if (!is.null(order) && !is.null(cols))
    stop("You must specify either order or cols.")

  if (!is.null(order)) {
    if (length(order) != nrow(x))
      stop("order parameter must have the same length as nrow(x)")

    if (!allow.duplicates && sum(duplicated(order)) > 0)
      stop("order parameter contains duplicated entries.")

    r <- range(order)
    if (is.na(r[1]))
      stop("order parameter contains NAs")
    if (r[1] < 1 || r[2] > nrow(x))
      stop("order parameter contains values that are out-of-range.")
  }
  else {
    order <- morder(x, cols, ...)
  }

  switch(class(x)[1],
         "big.matrix" = ReorderBigMatrix(x@address, order),
         "matrix" = switch(typeof(x),
            'integer' = ReorderRIntMatrix(x, nrow(x), ncol(x), order),
            'double' = ReorderRNumericMatrix(x, nrow(x), ncol(x), order),
         		'raw' = ReorderRIntMatrix(x, nrow(x), ncol(x), order),
         		stop("Unsupported matrix value type.")),
         stop("invalid class")
  )

  return(invisible(TRUE))

}

#' @rdname morder
#' @export
mpermuteCols <- function(x, order=NULL, rows=NULL,
                         allow.duplicates=FALSE, ...) {

  if (is.null(order) && is.null(rows))
    stop("You must specify either order or cols.")

  if (!is.null(order) && !is.null(rows))
    stop("You must specify either order or cols.")

  if (!is.null(order)) {
    if (length(order) != ncol(x))
      stop("order parameter must have the same length as ncol(x)")

    if (!allow.duplicates && sum(duplicated(order)) > 0)
      stop("order parameter contains duplicated entries.")

    r <- range(order)
    if (is.na(r[1]))
      stop("order parameter contains NAs")
    if (r[1] < 1 || r[2] > nrow(x))
      stop("order parameter contains values that are out-of-range.")
  } else {
    order <- morderCols(x, rows, ...)
  }

  switch(class(x)[1],
    "big.matrix" = {
      ReorderBigMatrixCols(x@address, order)
      SetColumnNames(x@address, colnames(x)[order])
    },
    "matrix" = {
      switch(typeof(x),
             'integer' = ReorderRIntMatrixCols(x, nrow(x), ncol(x), order),
             'raw' = ReorderRRawMatrixCols(x, nrow(x), ncol(x), order),
             'double' = ReorderRNumericMatrixCols(x, nrow(x), ncol(x), order),
             stop("Unsupported matrix value type."))
    },
    stop("unimplemented class")
  )

  invisible(TRUE)

}

#' @rdname big.matrix
#' @export
setGeneric('is.readonly', function(x) standardGeneric('is.readonly'))

#' @rdname big.matrix
setMethod('is.readonly', signature(x='big.matrix'),
  function(x) IsReadOnly(x@address))

#' @rdname big.matrix
#' @export
is.nil <- function(address) {
  if (!inherits(address, "externalptr")) {
    stop("address is not an externalptr.")
  }
  isnil(address)
}

getCType <- function(x) {
  if (!inherits(x, "big.matrix"))
    stop("getCType takes a big.matrix as an argument.")

  CGetType(x@address)
}

.addDimnames <- function(retList, nrow, ncol, drop) {
  if (drop && !is.matrix(retList[[1]]) ) {
    if (length(retList[[1]]) > 1) {
      if (ncol == 1) {
        thesenames <- retList[[2]]
      } else if (nrow == 1)
        thesenames <- retList[[3]]
    } else {
      thesenames <- NULL
    }
    if (!is.null(thesenames)) {
      names(retList[[1]]) <- thesenames
    }
  } else {
    if (!is.matrix(retList[[1]])) { dim(retList[[1]]) <- c(nrow, ncol) }
    if (!is.null(retList[[2]]) || !is.null(retList[[3]])) {
      dimnames(retList[[1]]) <- list( retList[[2]], retList[[3]] )
    }
  }
  return(retList[[1]])
}