SCM Repository

[matrix] Diff of /pkg/R/Matrix.R
 [matrix] / pkg / R / Matrix.R

Diff of /pkg/R/Matrix.R

revision 1714, Thu Dec 28 22:11:32 2006 UTC revision 1724, Sat Jan 13 21:06:51 2007 UTC
# Line 347  Line 347
347            })            })
348
349  ## A[ ij ] <- value,  where ij is (i,j) 2-column matrix :  ## A[ ij ] <- value,  where ij is (i,j) 2-column matrix :
350    ## ----------------   The cheap general method --- FIXME: provide special ones
351  .M.repl.i.2col <- function (x, i, j, value)  .M.repl.i.2col <- function (x, i, j, value)
352  {  {
353      nA <- nargs()      nA <- nargs()
# Line 354  Line 355
355          if(!is.integer(nc <- ncol(i)))          if(!is.integer(nc <- ncol(i)))
356              stop("'i' has no integer column number",              stop("'i' has no integer column number",
357                   " should never happen; please report")                   " should never happen; please report")
358            else if(!is.numeric(i) || nc != 2)
359                stop("such indexing must be by logical or 2-column numeric matrix")
360          if(is.logical(i)) {          if(is.logical(i)) {
361              i <- c(i) # drop "matrix"              i <- c(i) # drop "matrix"
362              return( callNextMethod() )              return( callNextMethod() )
363          } else if(!is.numeric(i) || nc != 2)          }
364              stop("such indexing must be by logical or 2-column numeric matrix")          if(!is.integer(i)) storage.mode(i) <- "integer"
365            if(any(i < 0))
366                stop("negative values are not allowed in a matrix subscript")
367            if(any(is.na(i)))
368                stop("NAs are not allowed in subscripted assignments")
369            if(any(i0 <- (i == 0))) # remove them
370                i <- i[ - which(i0, arr.ind = TRUE)[,"row"], ]
371            ## now have integer i >= 1
372          m <- nrow(i)          m <- nrow(i)
373          mod.x <- .type.kind[.M.kind(x)]          ## mod.x <- .type.kind[.M.kind(x)]
374          if(length(value) > 0 && m %% length(value) != 0)          if(length(value) > 0 && m %% length(value) != 0)
375              warning("number of items to replace is not a multiple of replacement length")              warning("number of items to replace is not a multiple of replacement length")
376          ## recycle:          ## recycle:
# Line 370  Line 380
380          ## inefficient -- FIXME -- (also loses "symmetry" unnecessarily)          ## inefficient -- FIXME -- (also loses "symmetry" unnecessarily)
381          for(k in seq_len(m))          for(k in seq_len(m))
382              x[i1[k], i2[k]] <- value[k]              x[i1[k], i2[k]] <- value[k]
x
383
384            x
385      } else stop("nargs() = ", nA, " should never happen; please report.")      } else stop("nargs() = ", nA, " should never happen; please report.")
386  }  }
387
388  setReplaceMethod("[", signature(x = "Matrix", i = "matrix", j = "missing",  setReplaceMethod("[", signature(x = "Matrix", i = "matrix", j = "missing",
389                                  value = "replValue"),                                  value = "replValue"),
390            .M.repl.i.2col)            .M.repl.i.2col)
# Line 382  Line 393
393  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",  setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
394                                  value = "Matrix"),                                  value = "Matrix"),
395                   function (x, i, j, value) {                   function (x, i, j, value) {
396  ### FIXME: *TEMPORARY* diagnostic output:  ### *TEMPORARY* diagnostic output:
397                       cat("<Matrix1>[i,j] <- <Matrix1>:\n<Matrix1> = x :")  ##                  cat("<Matrix1>[i,j] <- <Matrix1>:\n<Matrix1> = x :")
398                       str(x)  ##                  str(x)
399                       cat("<Matrix2> = value :")  ##                  cat("<Matrix2> = value :")
400                       str(value)  ##                  str(value)
401                       cat("i :"); if(!missing(i)) str(i) else cat("<missing>\n")  ##                  cat("i :"); if(!missing(i)) str(i) else cat("<missing>\n")
402                       cat("j :"); if(!missing(j)) str(j) else cat("<missing>\n")  ##                  cat("j :"); if(!missing(j)) str(j) else cat("<missing>\n")
403
404                       callGeneric(x=x, i=i, j=j, value = as.vector(value))                       callGeneric(x=x, i=i, j=j, value = as.vector(value))
405                   })                   })

Legend:
 Removed from v.1714 changed lines Added in v.1724