R/bigmemory.R

In cdeterman/bigmemory2: Manage massive matrices with shared memory and memory-mapped files

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

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

setClass('big.matrix', representation(address='externalptr'))
setClass('descriptor', representation(description='list'))
setClass('big.matrix.descriptor', contains='descriptor')

# Here, x is a big.matrix, and the result is a descriptor.

# Here, x is a descriptor, and the result is the description which is
# the relevant data needed for the attach.
setGeneric('description', function(x) standardGeneric('description'))

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

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=TRUE)
{
  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 == 'double') typeVal <- 8
  if (type == 'short') typeVal <- 2
  if (type == 'char') typeVal <- 1
  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) {
    address <- .Call('CreateSharedMatrix', as.double(nrow),
                as.double(ncol), as.character(colnames), as.character(rownames),
                as.integer(typeVal), as.double(init), as.logical(separated))
  } else {
    address <- .Call('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)
}

setGeneric('is.big.matrix', function(x) standardGeneric('is.big.matrix'))

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

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

setGeneric('as.big.matrix', 
  function(x, type=NULL, separated=FALSE,
           backingfile=NULL, backingpath=NULL,
           descriptorfile=NULL, binarydescriptor=FALSE, shared=TRUE) standardGeneric('as.big.matrix'))

setMethod('as.matrix', signature(x='big.matrix'),
  function(x) return(x[,]))

setMethod('as.big.matrix', signature(x='matrix'),
  function(x, type, separated, backingfile, backingpath, descriptorfile,
    binarydescriptor, shared)
  {
    if (!is.numeric(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=="integer" | type=="double" | type=="short" | type=="char") 
    {
      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[1:nrow(x),1: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("Coercing data.frame to matrix via factor level numberings.")
    if (is.null(type)) type <- options()$bigmemory.default.type
    if (type=="integer" | type=="double" | type=="short" | type=="char") 
    {
      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 1: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))
  })
  
colnames.bm <- function(x)
{
  ret <- .Call("GetColumnNamesBM", x@address)
  if (length(ret)==0) return(NULL)
  return(ret)
}

rownames.bm <- function(x)
{
  ret <- .Call("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.")
      .Call("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.")
      .Call("SetRowNames", x@address, value)
      return(x)
  })

setMethod('ncol', signature(x="big.matrix"),
  function(x) return(.Call("CGetNcol", x@address)))

setMethod('nrow', signature(x="big.matrix"), 
  function(x) return(.Call("CGetNrow", x@address)))

setMethod('dim', signature(x="big.matrix"),
  function(x) return(c(nrow(x), ncol(x))))

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 <- .Call("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 <- .Call("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 <- .Call("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 <- .Call("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 <- .Call("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]]

  # Call .Call C++
  return(.Call("GetIndivMatrixElements", x@address, as.double(i[,2]),
    as.double(i[,1])))
}


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 <- .Call("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 <- .Call("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 <- .Call("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 <- .Call("GetMatrixRows", x@address, as.double(i))
  mat = .addDimnames(retList, length(i), ncol(x), drop)
  return(mat)
}

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

setMethod("[",
  signature(x = "big.matrix", drop = "missing"),
  function(x, i, j) return(GetElements.bm(x, i, j)))

setMethod("[",
  signature(x = "big.matrix", drop = "logical"),
  function(x, i, j, drop) return(GetElements.bm(x, i, j, drop)))

setMethod("[",
  signature(x = "big.matrix", i="missing", drop = "missing"),
  function(x, j) return(GetCols.bm(x, j)))

setMethod("[",
  signature(x = "big.matrix", i="missing", drop = "logical"),
  function(x, j, drop) return(GetCols.bm(x, j, drop)))

setMethod("[",
  signature(x = "big.matrix", j="missing", drop = "missing"),
  function(x, i) return(GetRows.bm(x, i)))

setMethod("[",
  signature(x = "big.matrix", j="missing", drop = "logical"),
  function(x, i, drop) return(GetRows.bm(x, i, drop)))

setMethod("[",
  signature(x = "big.matrix", i="missing", j="missing", drop = "missing"),
  function(x) return(GetAll.bm(x)))

setMethod("[",
  signature(x = "big.matrix", i="missing", j="missing", drop = "logical"),
  function(x, drop) return(GetAll.bm(x, drop)))

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


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 <- .Call("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 <- .Call("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) != "integer"))) ) 
  {
    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 <- length(i) * 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(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")
    }
  }
  # Note: we pass doubles as doubles, but anything else as integers.
  if (typeof(x) == 'double') {
    .Call("SetMatrixElements", x@address, as.double(j), as.double(i), 
          as.double(value))
  } else {
    .Call("SetMatrixElements", x@address, as.double(j), as.double(i), 
          as.integer(value))
  }
  return(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 <- .Call("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 <- .Call("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"))) )
  {
    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=''))
  }

  # Call appropriate .Call C++
  if (typeof(x) == 'double') {
    .Call("SetIndivMatrixElements", x@address, as.double(i[,2]),
      as.double(i[,1]), as.double(value))
  } else {
    .Call("SetIndivMatrixElements", x@address, as.double(i[,2]),
      as.double(i[,1]), as.integer(value))
  }
  return(x)
}


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 <- .Call("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"))) )
  {
    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 <- nrow(x) * 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")
    }
  }
  # Note: we pass doubles as doubles, but anything else as integers.
  if (typeof(x) == 'double') 
  {
    .Call("SetMatrixCols", x@address, as.double(j), as.double(value))
  } 
  else 
  {
    .Call("SetMatrixCols", x@address, as.double(j), as.integer(value))
  }
  return(x)
}

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 <- .Call("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"))) )
  {
    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 <- length(i) * 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")
    }
  }
  # Note: we pass doubles as doubles, but anything else as integers.
  if (typeof(x) == 'double') {
    .Call("SetMatrixRows", x@address, as.double(i), as.double(value))
  } 
  else 
  {
    .Call("SetMatrixRows", x@address, as.double(i), as.integer(value))
  }
  return(x)
}

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"))) )
  {
    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 <- nrow(x) * 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")
    }
  }
  # Note: we pass doubles as doubles, but anything else as integers.
  if (typeof(x) == 'double') 
  {
    .Call("SetMatrixAll", x@address, as.double(value))
  } 
  else 
  {
    .Call("SetMatrixAll", x@address, as.integer(value))
  }
  return(x)
}

setMethod('[<-',
  signature(x = "big.matrix"),
  function(x, i, j, value) return(SetElements.bm(x, i, j, value)))

setMethod('[<-',
  signature(x = "big.matrix", i="missing"),
  function(x, j, value) return(SetCols.bm(x, j, value)))

setMethod('[<-',
  signature(x = "big.matrix", j="missing"),
  function(x, i, value) return(SetRows.bm(x, i, value)))

setMethod('[<-',
  signature(x = "big.matrix", i="missing", j="missing"),
  function(x, value) return(SetAll.bm(x, value)))

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

setMethod('typeof', signature(x="big.matrix"),
  function(x) return(.Call('GetTypeString', x@address)))

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[1:n,])
  })

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),])
  })

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

setGeneric('mwhich', function(x, cols, vals, comps, op = 'AND')
  standardGeneric('mwhich'))

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

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

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

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, 1: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 1: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 (whichFuncName == 'MWhichBigMatrix')
    ret = .Call(whichFuncName, x@address, as.double(testCol), 
                as.double(minVal), as.double(maxVal), 
                as.integer(chkmin), as.integer(chkmax), as.integer(opVal))
  else
    ret = .Call(whichFuncName, x, nrow(x),
                as.double(testCol), 
                as.double(minVal), as.double(maxVal), 
                as.integer(chkmin), as.integer(chkmax), as.integer(opVal))

  return(ret)
}

setMethod('dimnames', signature(x = "big.matrix"),
  function(x) return(list(rownames.bm(x), colnames.bm(x))))

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


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=TRUE) 
  standardGeneric('read.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=TRUE)
  {
    if (!is.logical(header))
      stop("header argument must be logical")
    if (is.logical(col.names) || is.logical(row.names))
      stop("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("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 <- .Call("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=TRUE)

    # 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:
    .Call('ReadMatrix', filename, bigMat@address, 
          as.integer(skip+headerOffset), as.double(numRows), 
          as.double(numCols), as.character(sep), as.logical(has.row.names),
          as.logical(!ignore.row.names))

    return(bigMat)
  })

setGeneric('write.big.matrix', 
  function(x, filename, row.names=FALSE, col.names=FALSE, sep=",") 
    standardGeneric('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 & !.Call("HasRowColNames",x@address)[1]) {
      row.names <- FALSE
      warning("No row names exist, overriding your row.names option.\n")
    }
    if (col.names & !.Call("HasRowColNames",x@address)[2]) {
      col.names <- FALSE
      warning("No column names exist, overriding your col.names option.\n")
    }
    .Call('WriteMatrix', x@address, filename, as.logical(row.names), 
      as.logical(col.names), sep)
    invisible(NULL)
  })

setGeneric('is.separated', function(x) standardGeneric('is.separated'))

setMethod('is.separated', signature(x='big.matrix'),
  function(x) return(.Call("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 <- .Call("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 <- .Call("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)
}

deepcopy <- function(x, cols=NULL, rows=NULL, 
                     y=NULL, type=NULL, separated=NULL,
                     backingfile=NULL, backingpath=NULL,
                     descriptorfile=NULL, binarydescriptor=FALSE,
                     shared=TRUE)
{
  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))
    .Call("CDeepCopy", x@address, y@address, as.double(rows), as.double(cols), 
      getOption("bigmemory.typecast.warning"))
  else
    for (i in 1: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 '\'.

setGeneric('is.sub.big.matrix', function(x)
	standardGeneric('is.sub.big.matrix'))

setMethod('is.sub.big.matrix', signature(x='big.matrix'),
  function(x) return(.Call('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.
setGeneric('sub.big.matrix', function(x, firstRow=1, lastRow=NULL,
  firstCol=1, lastCol=NULL, backingpath=NULL) standardGeneric('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))
  })

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"))
    }
    .Call("SetRowOffsetInfo", rbm@address, 
          as.double(rowOffset + .Call("GetRowOffset", rbm@address)), 
          as.double(numRows) )
    .Call("SetColumnOffsetInfo", rbm@address, 
          as.double(colOffset + .Call("GetColOffset", rbm@address)),
          as.double(numCols))
    return(rbm)
  })

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')
  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 == 'double') typeVal <- 8
  if (type == 'short') typeVal <- 2
  if (type == 'char') typeVal <- 1
  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 <- dirname(backingfile)
    backingfile <- basename(backingfile)
  }
  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)
  backingpath <- file.path(backingpath, '.')
  backingpath <- substr( backingpath, 1, nchar(backingpath)-1 )
	address <- .Call('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 <- file.path(backingpath, descriptorfile) 
    if(binarydescriptor)
    {
      saveRDS(describe(x), file=descriptorfilepath)
    } else {
      dput(describe(x), descriptorfilepath)
    }
  }
  return(x)
}

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

DescribeBigMatrix = function(x)
{
  if (!is.filebacked(x))
  {
    if (is.shared(x)) {
      ret <- list(sharedType = 'SharedMemory',
                  sharedName = shared.name(x), 
                  totalRows = .Call("GetTotalRows", x@address),
                  totalCols = .Call("GetTotalColumns", x@address),
                  rowOffset = .Call("GetRowOffset", x@address),
                  colOffset = .Call("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
  {
    ret = list(sharedType='FileBacked',
               filename=file.name(x),
               totalRows = .Call("GetTotalRows", x@address),
               totalCols = .Call("GetTotalColumns", x@address),
               rowOffset = .Call("GetRowOffset", x@address),
               colOffset = .Call("GetColOffset", x@address),
               nrow=nrow(x), ncol=ncol(x),
               rowNames=rownames(x), colNames=colnames(x), type=typeof(x), 
               separated=is.separated(x))
  }
}

attach.big.matrix = function(obj, ...)
{
  if (!is.null( list(...)[['backingpath']]))
    return(attach.resource(obj, path=list(...)[['backingpath']], ...))
  return(attach.resource(obj, ...))
}

setMethod('attach.resource', signature(obj='character'),
  function(obj, ...)
  {
    path <- list(...)[['path']]
    if (is.null(path))
    {
      path <- '.'
    }
    path <- path.expand(path)
    if (basename(obj) != obj)
    {
      if (path != ".")
        warning(paste("Two paths were specified in attach.resource.",
          "The one associated with the file will be used.", sep="  "))
      path <- dirname(obj)
      obj <- basename(obj) 
    }
    
    fileWithPath <- file.path(path, obj)
    fi = file.info(fileWithPath)
    if (is.na(fi$isdir))
      stop( paste("The file", fileWithPath, "could not be found") )
    if (fi$isdir)
      stop( fileWithPath, "is a directory" )
    info <- tryCatch(readRDS(file=fileWithPath), error=function(er){return(dget(fileWithPath))})
    return(attach.resource(info, path=path))
  })

setMethod('attach.resource', signature(obj='big.matrix.descriptor'),
  function(obj, ...)
  {
    path <- list(...)[['path']]
    if (is.null(path))
    {
      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 == 'double') typeLength <- 8
    if (is.null(typeLength)) 
      stop('invalid type')
    path <- path.expand(path)
    fi = file.info(path)
    if (path != '.' && is.na(fi$isdir))
      stop( paste("The directory", path, "could not be found") )
    if (!is.na(fi$isdir) && !fi$isdir)
      stop( paste(path, "is not a directory.") )
    path = file.path(path, '.')
    path <- substr(path, 1, nchar(path)-1)
    if (substr(path, nchar(path), nchar(path)) == "/") {
      path <- substr(path, 1, nchar(path)-1)
    }

    readOnly <- ifelse( is.null(list(...)$readonly), FALSE, list(...)$readonly)
    if (!is.logical(readOnly)) {
      stop("The readOnly argument must be of type logical")
    }
    
    if (info$sharedType == 'SharedMemory')
    {
      address <- .Call('CAttachSharedBigMatrix', info$sharedName, 
        info$totalRows, info$totalCols, as.character(info$rowNames), 
        as.character(info$colNames), as.integer(typeLength), info$separated,
        readOnly)
    }
    else
    {
      if (!info$separated) {
        if (!file.exists(file.path(path, info$filename)))
        {
          stop(paste("The backing file", paste(path, info$filename, sep=''),
            "could not be found"))
        }
      } else { 
        # It's separated and we need to check for each column.
        for (i in 1:info$ncol) {
          fn <- paste(info$filename, "_column_", (i-1), sep='')
          if (!file.exists(file.path(path, fn)))
          {
            stop(paste("The backing file", file.path(path, fn), 
              "could not be found"))
          }
        }
      }
      address <- .Call('CAttachFileBackedBigMatrix', 
        info$filename, path, info$totalRows, info$totalCols, 
        as.character(info$rowNames), as.character(info$colNames), 
        as.integer(typeLength), info$separated, readOnly)
    }
    if (!is.null(address)) 
    {
      .Call("SetRowOffsetInfo", address, info$rowOffset, info$nrow)
      .Call("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)  
  })

setGeneric('is.filebacked', function(x) standardGeneric('is.filebacked'))

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

setGeneric('shared.name', function(x) standardGeneric('shared.name'))

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

setGeneric('file.name', function(x) standardGeneric('file.name'))

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

transpose.big.matrix <- function(x, backingfile=NULL,
                     backingpath=NULL, descriptorfile=NULL,
                     binarydescriptor=FALSE, shared=TRUE) {
  temp <- big.matrix(nrow=ncol(x), ncol=nrow(x), type=typeof(x),
    dimnames=dimnames(x)[[2:1]], separated=is.separated(x),
    backingfile=backingfile, backingpath=backingpath, 
    descriptorfile=descriptorfile, binarydescriptor=binarydescriptor,
    shared=TRUE)

  for (i in 1:nrow(x)) {
    temp[,i] <- x[i,]
  }

  return(temp)
}


setGeneric('flush', function(con) standardGeneric('flush'))

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(.Call("Flush", con@address)))
  })

setGeneric('is.shared', function(x) standardGeneric('is.shared'))

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

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.")
  }

  if (class(x) == 'big.matrix')
  {
    return(.Call('OrderBigMatrix', x@address, as.double(cols), 
      as.integer(na.last), as.logical(decreasing) ))
  }
  else if (class(x) == 'matrix')
  {
    if (typeof(x) == 'integer')
    {
      return(.Call('OrderRIntMatrix', x, nrow(x), as.double(cols), 
        as.integer(na.last), as.logical(decreasing) ))
    }
    else if (typeof(x) == 'double')
    {
      return(.Call('OrderRNumericMatrix', x, nrow(x), as.double(cols), 
        as.integer(na.last), as.logical(decreasing) ))
    }
    else
      stop("Unsupported matrix value type.")
  }
  else
    stop("Unsupported matrix type.")
}

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, ...)

  if (class(x) == 'big.matrix')
  {
    .Call('ReorderBigMatrix', x@address, order)
  }
  else if (class(x) == 'matrix')
  {
    if (typeof(x) == 'integer')
    {
      .Call('OrderRIntMatrix', x, nrow(x), ncol(x), order)
    }
    else if (typeof(x) == 'double')
    {
      .Call('ReorderRNumericMatrix', x, nrow(x), ncol(x), order)
    }
    else
      stop("Unsupported matrix value type.")
  }
  return(invisible(TRUE))
  
}

is.nil <- function(address) {
  if (class(address)!="externalptr") stop("address is not an externalptr.")
  ans <- .Call("isnil", address)
  return(ans)
}

setGeneric('is.readonly', function(x) standardGeneric('is.readonly'))

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

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

  return(.Call("CGetType", x@address, PACKAGE="bigmemory"))
}

.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]])) { retList[[1]] = matrix(retList[[1]], nrow=nrow, ncol=ncol) }
    if (!is.null(retList[[2]]) || !is.null(retList[[3]])) {
      dimnames(retList[[1]]) <- list( retList[[2]], retList[[3]] )
    }
  }
  return(retList[[1]])
}


resizeBM <- function(obj, nRow, nCol, ...){
  if(class(obj) != "big.matrix"){
    stop("Error: 'obj' is not of class 'big.matrix'")
  }
  info <- describe(obj)@description
  
  newRows <- info$totalRows + nRow
  newCols <- info$totalCols + nCol
  
  # Check if want to only allow reshaping instead of increasing overall size
  # Currently unable to add rows.
  
#   if(info$totalRows*info$totalCols != newRows*newCols){
#     stop("Error: new dimensions product must equal old dimensions product")
#   }
  
  typeLength <- NULL
  if (info$type == 'char') typeLength <- 1
  if (info$type == 'short') typeLength <- 2
  if (info$type == 'integer') typeLength <- 4
  if (info$type == 'double') typeLength <- 8
  
  readOnly <- ifelse( is.null(list(...)$readonly), FALSE, list(...)$readonly)
  if (!is.logical(readOnly)) {
    stop("The readOnly argument must be of type logical")
  }
  
  address <- .Call('CResizeSharedBigMatrix', obj@address, info$sharedName, 
                   newRows, newCols, as.character(info$rowNames), 
                   as.character(info$colNames), as.integer(typeLength), info$separated,
                   readOnly)
  ret <- paste(c("big.matrix", address, "was modified"), collapse=" ")
  return(ret)
}