# SCM Repository

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

# Diff of /pkg/R/sparseMatrix.R

revision 2094, Tue Dec 4 23:41:41 2007 UTC revision 2095, Wed Dec 5 17:57:24 2007 UTC
# Line 525  Line 525
525
526  setAs("factor", "sparseMatrix", function(from) fac2sparse(from, to = "d"))  setAs("factor", "sparseMatrix", function(from) fac2sparse(from, to = "d"))
527
528  # xtabs returning a sparse matrix.  This should probably be an option  ## xtabs returning a sparse matrix.  This is cut'n'paste
529  # for the xtabs function  ## of xtabs() in <Rsrc>/src/library/stats/R/xtabs.R ;
530  sxtabs <- function (formula = ~., data = parent.frame(), subset, na.action,  ## with the new argument 'sparse'
531      exclude = c(NA, NaN), drop.unused.levels = FALSE)  xtabs <- function(formula = ~., data = parent.frame(), subset, sparse = FALSE,
532                      na.action, exclude = c(NA, NaN), drop.unused.levels = FALSE)
533  {  {
534      if (missing(formula) && missing(data))      if (missing(formula) && missing(data))
535          stop("must supply either 'formula' or 'data'")          stop("must supply either 'formula' or 'data'")
536      if (!missing(formula)) {      if (!missing(formula)) {
537            ## We need to coerce the formula argument now, but model.frame
538            ## will coerce the original version later.
539          formula <- as.formula(formula)          formula <- as.formula(formula)
540          if (!inherits(formula, "formula"))          if (!inherits(formula, "formula"))
541              stop("'formula' missing or incorrect")              stop("'formula' missing or incorrect")
# Line 542  Line 545
545      m <- match.call(expand.dots = FALSE)      m <- match.call(expand.dots = FALSE)
546      if (is.matrix(eval(m\$data, parent.frame())))      if (is.matrix(eval(m\$data, parent.frame())))
547          m\$data <- as.data.frame(data)          m\$data <- as.data.frame(data)
548      m\$... <- m\$exclude <- m\$drop.unused.levels <- NULL      m\$... <- m\$exclude <- m\$drop.unused.levels <- m\$sparse <- NULL
549      m[[1]] <- as.name("model.frame")      m[[1]] <- as.name("model.frame")
550      mf <- eval(m, parent.frame())      mf <- eval(m, parent.frame())
551      if(length(formula) == 2) {      if(length(formula) == 2) {
# Line 558  Line 561
561          if(!is.factor(u)) u <- factor(u, exclude = exclude)          if(!is.factor(u)) u <- factor(u, exclude = exclude)
562          u[ , drop = drop.unused.levels]          u[ , drop = drop.unused.levels]
563      })      })
564        if(!sparse) { ## identical to stats::xtabs
565            x <-
566                if(is.null(y))
567                    do.call("table", by)
568                else if(NCOL(y) == 1)
569                    tapply(y, by, sum)
570                else {
571                    z <- lapply(as.data.frame(y), tapply, by, sum)
572                    array(unlist(z),
573                          dim = c(dim(z[[1]]), length(z)),
574                          dimnames = c(dimnames(z[[1]]), list(names(z))))
575                }
576            x[is.na(x)] <- 0
577            class(x) <- c("xtabs", "table")
578            attr(x, "call") <- match.call()
579            x
580
581        } else { ## sparse
582      if (length(by) != 2)      if (length(by) != 2)
583          stop("sxtabs applies only to two-way tables")              stop("xtabs(*, sparse=TRUE) applies only to two-way tables")
584      rows <- by[[1]]      rows <- by[[1]]
585      cols <- by[[2]]      cols <- by[[2]]
586      rl <- levels(rows)      rl <- levels(rows)
587      cl <- levels(cols)      cl <- levels(cols)
588            ## FIXME?  y == 1 seems the most common case.
589            ##         Shouldn't we rather use a pattern matrix then ??
590      if (is.null(y))      if (is.null(y))
591          y <- rep(1, length(rows))              y <- rep.int(1, length(rows))
592            else if(!is.double(y))
593                y <- as.double(y)
594      as(new("dgTMatrix",      as(new("dgTMatrix",
595             list(i = as.integer(rows),                 i = as.integer(rows) - 1L,
596                  j = as.integer(cols),                 j = as.integer(cols) - 1L,
597                  x = y,                  x = y,
598                  Dim = c(length(rl), length(cl)),                  Dim = c(length(rl), length(cl)),
599                  Dimnames = list(rl, cl))), "CsparseMatrix")                 Dimnames = list(rl, cl)), "CsparseMatrix")
600        }
601  }  }

Legend:
 Removed from v.2094 changed lines Added in v.2095

 root@r-forge.r-project.org ViewVC Help Powered by ViewVC 1.0.0
Thanks to: