slam/0000755000175100001440000000000012316730752011232 5ustar hornikusersslam/tests/0000755000175100001440000000000012262760225012372 5ustar hornikusersslam/tests/extract.Rout.save0000644000175100001440000001242512231145134015650 0ustar hornikusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: i686-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > ## > library("slam") > ## > x <- simple_sparse_zero_array(dim = c(3, 2)) > > x[1] [1] 0 > x[matrix(c(1, 1), nrow = 1)] [1] 0 > > ## > x <- as.simple_sparse_array(matrix(1:6, ncol = 2)) > x[1] [1] 1 > x[matrix(c(1, 1), nrow = 1)] [1] 1 > > x[1.1] ## truncation [1] 1 > > x[integer()] integer(0) > x[matrix(integer(), ncol = 2)] integer(0) > > > ## missing values > x[c(1, 0, NA, 2)] [1] 1 NA 2 > > k <- matrix(c(1, 1, 1, 0, 1, NA), ncol = 2, byrow = TRUE) > k [,1] [,2] [1,] 1 1 [2,] 1 0 [3,] 1 NA > x[k] [1] 1 NA > > ## wrong dimensions > dim(k) <- c(2,3) > as.vector(k) [1] 1 1 1 1 0 NA > x[k] [1] 1 1 1 1 NA > > > z <- x[c(1,3),] > data.frame(v = z$v, i = z$i, + k = .Call("_vector_index", z$dim, z$i)) v i.1 i.2 k 1 1 1 1 1 2 3 2 1 2 3 4 1 2 3 4 6 2 2 4 > > > ## drop not implemented > x[ 1,] A simple sparse array of dimension 1x2. > x[-1,] A simple sparse array of dimension 2x2. > try(x[1, NA_integer_]) ## not implemented Error in `[.simple_sparse_array`(x, 1, NA_integer_) : NA indices currently not allowed > str(x[0,]) List of 4 $ i : int[0 , 1:2] $ v : int(0) $ dim : int [1:2] 0 2 $ dimnames: NULL - attr(*, "class")= chr "simple_sparse_array" > str(x[0, 0]) List of 4 $ i : int[0 , 1:2] $ v : int(0) $ dim : int [1:2] 0 0 $ dimnames: NULL - attr(*, "class")= chr "simple_sparse_array" > > x[c(1, 8)] ## out of bounds allowed [1] 1 NA > try(x[1, 8]) ## not allowed Error in `[.simple_sparse_array`(x, 1, 8) : subscript out of bounds > > dim(k) <- c(3,2) > k[6] <- 3 > k [,1] [,2] [1,] 1 1 [2,] 1 0 [3,] 1 3 > try(x[k]) ## not allowed Error in `[.simple_sparse_array`(x, k) : subscript out of bounds > > ## > x <- simple_triplet_zero_matrix(nrow = 3, ncol = 2) > > x[1] [1] 0 > x[matrix(c(1, 1), nrow = 1)] [1] 0 > > ## > x <- as.simple_triplet_matrix(matrix(1:6, ncol = 2)) > x[1] [1] 1 > x[matrix(c(1, 1), nrow = 1)] [1] 1 > > x[1.1] ## truncation [1] 1 > > x[integer()] integer(0) > x[matrix(integer(), ncol = 2)] integer(0) > > > ## missing values > x[c(1, 0, NA, 2)] [1] 1 NA 2 > > k <- matrix(c(1, 1, 1, 0, 1, NA), ncol = 2, byrow = TRUE) > k [,1] [,2] [1,] 1 1 [2,] 1 0 [3,] 1 NA > x[k] [1] 1 NA > > ## wrong dimensions > dim(k) <- c(2,3) > as.vector(k) [1] 1 1 1 1 0 NA > x[k] [1] 1 1 1 1 NA > > > z <- x[c(1,3),] > data.frame(v = z$v, i = z$i, j = z$j, + k = .Call("_vector_index", c(z$nrow, z$ncol), cbind(z$i, z$j))) v i j k 1 1 1 1 1 2 3 2 1 2 3 4 1 2 3 4 6 2 2 4 > > > ## drop not implemented > x[ 1,] A 1x2 simple triplet matrix. > x[-1,] A 2x2 simple triplet matrix. > try(x[1, NA_integer_]) ## not implemented Error in `[.simple_triplet_matrix`(x, 1, NA_integer_) : NA indices not allowed. > str(x[0,]) List of 6 $ i : int(0) $ j : int(0) $ v : int(0) $ nrow : int 0 $ ncol : int 2 $ dimnames: NULL - attr(*, "class")= chr "simple_triplet_matrix" > str(x[0, 0]) List of 6 $ i : int(0) $ j : int(0) $ v : int(0) $ nrow : int 0 $ ncol : int 0 $ dimnames: NULL - attr(*, "class")= chr "simple_triplet_matrix" > > x[c(1, 8)] ## out of bounds allowed [1] 1 NA > try(x[1, 8]) ## not allowed Error in `[.simple_triplet_matrix`(x, 1, 8) : subscript out of bounds > > dim(k) <- c(3,2) > k[6] <- 3 > k [,1] [,2] [1,] 1 1 [2,] 1 0 [3,] 1 3 > try(x[k]) ## not allowed Error in `[.simple_triplet_matrix`(x, k) : subscript out of bounds > > > x[c(TRUE, FALSE)] [1] 1 3 5 > x[c(TRUE, FALSE),] A 2x2 simple triplet matrix. > > ## reference > x <- matrix(1:6, ncol = 2) > x[c(1, 0, NA, 2)] [1] 1 NA 2 > > try(x[-c(1, NA)]) ## not allowed Error in x[-c(1, NA)] : only 0's may be mixed with negative subscripts > > ## missing allowed > k <- matrix(c(1, 1, 1, 0, 1, NA), ncol = 2, byrow = TRUE) > k [,1] [,2] [1,] 1 1 [2,] 1 0 [3,] 1 NA > x[k] [1] 1 NA > > dim(k) <- c(2, 3) > as.vector(k) [1] 1 1 1 1 0 NA > x[k] [1] 1 1 1 1 NA > > > x[ 1,] [1] 1 4 > x[-1,] [,1] [,2] [1,] 2 5 [2,] 3 6 > x[ 1, NA] ## wildcard [1] NA NA > > x[0,] ## does not drop [,1] [,2] > x[0,0] <0 x 0 matrix> > > x[c(1, 8)] ## out of bounds allowed [1] 1 NA > try(x[1, 8]) ## not allowed Error in x[1, 8] : subscript out of bounds > > dim(k) <- c(3,2) > k[6] <- 3 > k [,1] [,2] [1,] 1 1 [2,] 1 0 [3,] 1 3 > try(x[k]) ## not allowed Error in x[k] : subscript out of bounds > > x[c(TRUE, FALSE)] [1] 1 3 5 > x[c(TRUE, FALSE),] [,1] [,2] [1,] 1 4 [2,] 3 6 > > ### > > proc.time() user system elapsed 0.380 0.024 0.400 slam/tests/stm.R0000644000175100001440000000344212230675767013336 0ustar hornikusers library("slam") set.seed(20090626) ### x <- sample(0:5, 100, T, prob=c(.8,rep(.04,5))) x <- matrix(as.logical(x), nrow = 20, dimnames = list(rows = 1:20, cols = LETTERS[1:5])) x xst <- as.simple_triplet_matrix(x) xst identical(rowSums(x), row_sums(xst)) identical(colSums(x), col_sums(xst)) identical(rowMeans(x), row_means(xst)) identical(colMeans(x), col_means(xst)) ## NAs xna <- x n <- prod(dim(x)) is.na(xna) <- sample(seq_len(n), ceiling(n * .1)) xna xnast <- as.simple_triplet_matrix(xna) xnast ## default method identical(rowSums(xna), row_sums(xna)) identical(colSums(xna), col_sums(xna)) identical(rowMeans(xna), row_means(xna)) identical(colMeans(xna), col_means(xna)) identical(rowSums(xna), row_sums(xnast)) identical(colSums(xna), col_sums(xnast)) identical(rowMeans(xna), row_means(xnast)) identical(colMeans(xna), col_means(xnast)) identical(rowSums(xna, na.rm = TRUE), row_sums(xnast, na.rm = TRUE)) identical(colSums(xna, na.rm = TRUE), col_sums(xnast, na.rm = TRUE)) identical(rowMeans(xna, na.rm = TRUE), row_means(xnast, na.rm = TRUE)) identical(colMeans(xna, na.rm = TRUE), col_means(xnast, na.rm = TRUE)) ## cross-product identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(xst)) identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(xst, x)) identical(tcrossprod(x[1:10,], x[11:20,]), tcrossprod_simple_triplet_matrix(xst[1:10,], xst[11:20,])) x <- matrix(c(1, 0, 0, 2, 1, NA), nrow = 3) x s <- as.simple_triplet_matrix(x) identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(s)) identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(s, x)) identical(tcrossprod(x[2:3,], x[1,, drop = FALSE]), tcrossprod_simple_triplet_matrix(s[2:3,], s[1,])) identical(tcrossprod(x[1,, drop = FALSE], x[2:3,]), tcrossprod_simple_triplet_matrix(s[1,], s[2:3,])) ### slam/tests/stm_subassign.Rout.save0000644000175100001440000000303312103507072017053 0ustar hornikusers R version 2.14.2 Patched (2012-02-29 r58546) Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > ## > library("slam") > > s <- as.simple_triplet_matrix(diag(4)) > s[1:8] <- 1:8 > as.matrix(s) [,1] [,2] [,3] [,4] [1,] 1 5 0 0 [2,] 2 6 0 0 [3,] 3 7 1 0 [4,] 4 8 0 1 > > s[2:3,] <- 1:8 > as.matrix(s) [,1] [,2] [,3] [,4] [1,] 1 5 0 0 [2,] 1 3 5 7 [3,] 2 4 6 8 [4,] 4 8 0 1 > > s[,2:3] <- 1:8 > as.matrix(s) [,1] [,2] [,3] [,4] [1,] 1 1 5 0 [2,] 1 2 6 7 [3,] 2 3 7 8 [4,] 4 4 8 1 > > s[] <- 1:8 > as.matrix(s) [,1] [,2] [,3] [,4] [1,] 1 5 1 5 [2,] 2 6 2 6 [3,] 3 7 3 7 [4,] 4 8 4 8 > > ## > local({ + k <- 2:3 + ## Implementing class. + a <- as.simple_sparse_array(s) + a[,k] + a[,k] <- 1:8 + s[,k] <- 1:8 + stopifnot(identical(as.array(a), as.array(s))) + }) > > ### > slam/tests/apply.Rout.save0000644000175100001440000000574212262026562015336 0ustar hornikusers R version 2.14.2 Patched (2012-02-29 r58546) Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > set.seed(201311) > > ### > x <- matrix(rnorm(100), nrow = 20, + dimnames = list(1:20, LETTERS[1:5]) + ) > x[sample(100, 80)] <- 0 > > s <- as.simple_triplet_matrix(x) > s A 20x5 simple triplet matrix. > > ## > identical(apply(x, 2L, var), colapply_simple_triplet_matrix(s, var)) [1] TRUE > identical(apply(x, 1L, var), rowapply_simple_triplet_matrix(s, var)) [1] TRUE > > ## > k <- 1:2 > z <- var(x[, k], x[, -k]) > identical(z, crossapply_simple_triplet_matrix(s[, k], s[, -k], FUN = var)) [1] TRUE > identical(z, crossapply_simple_triplet_matrix(x[, k], s[, -k], FUN = var)) [1] TRUE > > identical(z, + tcrossapply_simple_triplet_matrix(t(s[, k]), t(s[, -k]), FUN = var)) [1] TRUE > identical(z, + tcrossapply_simple_triplet_matrix(t(x[, k]), t(s[, -k]), FUN = var)) [1] TRUE > > z <- var(x) > identical(z, crossapply_simple_triplet_matrix(s, FUN = var)) [1] TRUE > > ## null-dimensions > z <- var(x[, 0], x) > z A B C D E > all.equal(z, crossapply_simple_triplet_matrix(s[, 0], s, FUN = var)) [1] TRUE > all.equal(z, crossapply_simple_triplet_matrix(x[, 0], s, FUN = var)) [1] TRUE > > try(crossapply_simple_triplet_matrix(x[, 0], s, FUN = var, use = "all.obs")) Error in FUN(x, y, ...) : 'x' is empty > > z <- var(x, x[, 0]) > z A B C D E > all.equal(z, crossapply_simple_triplet_matrix(s, s[, 0], FUN = var)) [1] TRUE > all.equal(z, crossapply_simple_triplet_matrix(x, s[, 0], FUN = var)) [1] TRUE > > > z <- var(x[, 0]) > z <0 x 0 matrix> > all.equal(z, crossapply_simple_triplet_matrix(s[, 0], s[, 0], FUN = var)) [1] TRUE > all.equal(z, crossapply_simple_triplet_matrix(x[, 0], s[, 0], FUN = var)) [1] TRUE > > all.equal(z, crossapply_simple_triplet_matrix(s[, 0], FUN = var)) [1] TRUE > > z <- var(x[0, ]) > z A B C D E A NA NA NA NA NA B NA NA NA NA NA C NA NA NA NA NA D NA NA NA NA NA E NA NA NA NA NA > all.equal(z, crossapply_simple_triplet_matrix(s[0, ], s[0, ], FUN = var)) [1] TRUE > all.equal(z, crossapply_simple_triplet_matrix(x[0, ], s[0, ], FUN = var)) [1] TRUE > > all.equal(z, crossapply_simple_triplet_matrix(s[0, ], FUN = var)) [1] TRUE > > ## non-scalar > z <- crossapply_simple_triplet_matrix(s, s, FUN = ">") > all.equal(z, crossapply_simple_triplet_matrix(x, s, FUN = ">")) [1] TRUE > > all.equal(z[lower.tri(z)], + crossapply_simple_triplet_matrix(s, FUN = ">")[lower.tri(z)]) [1] TRUE > > ### > slam/tests/stm_rollup.R0000644000175100001440000000256311515512255014721 0ustar hornikusers library("slam") set.seed(201008) ## test x <- matrix(sample(c(0,1), 100L, TRUE, prob = c(.9,.1)), 5L) dim(x) INDEX <- sample(1:4, 20L, TRUE) s <- as.simple_triplet_matrix(x) z <- as.matrix(s) rollup(z, 2L, rep(1L, 20L), fivenum) identical(rollup(z, 2L, INDEX), as.matrix(rollup(s, 2L, INDEX))) identical(rollup(t(z), 1L, INDEX), as.matrix(rollup(t(s), 1L, INDEX))) ## NA indexes k <- INDEX is.na(k) <- k == 1L any(is.na(k)) identical(as.matrix(rollup(s, 2L, k)), rollup(z, 2L, k)) ## other data types s$v <- as.integer(s$v) identical(rollup(z, 2L, INDEX), as.matrix(rollup(s, 2L, INDEX))) ## NA values is.na(s$v) <- 1:2 z <- as.matrix(s) z[] <- as.double(z) # coerce identical(rollup(z, 2L, INDEX), as.matrix(rollup(s, 2L, INDEX))) identical(rollup(z, 2L, INDEX, na.rm = TRUE), as.matrix(rollup(s, 2L, INDEX, na.rm = TRUE))) ## s$v <- as.double(s$v) identical(rollup(z, 2L, INDEX, na.rm = TRUE), as.matrix(rollup(s, 2L, INDEX, na.rm = TRUE))) ## s <- as.simple_sparse_array(s) z <- as.array(z) identical(rollup(z, 2L, INDEX, na.rm = TRUE), as.array(rollup(s, 2L, INDEX, na.rm = TRUE))) ## INDEX <- rep(1, dim(x)[2L]) identical(rollup(z, 2L, INDEX, na.rm = TRUE), as.array(rollup(s, 2L, INDEX, na.rm = TRUE))) s <- as.simple_triplet_matrix(s) identical(rollup(z, 2L, INDEX, na.rm = TRUE), as.array(rollup(s, 2L, INDEX, na.rm = TRUE))) ### slam/tests/abind.Rout.save0000644000175100001440000000465212311556616015270 0ustar hornikusers R Under development (unstable) (2014-03-17 r65202) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > ## > library("slam") > x <- matrix(1:12, 4, dimnames = list(NULL, B = 1:3)) > s <- as.simple_sparse_array(x) > s A simple sparse array of dimension 4x3. > > extend_simple_sparse_array(s, 0L) A simple sparse array of dimension 1x4x3. > extend_simple_sparse_array(s, -1L) ## the same A simple sparse array of dimension 1x4x3. > extend_simple_sparse_array(s, 1L) A simple sparse array of dimension 4x1x3. > extend_simple_sparse_array(s, 2L) A simple sparse array of dimension 4x3x1. > extend_simple_sparse_array(s, -3L) ## the same A simple sparse array of dimension 4x3x1. > > extend_simple_sparse_array(s, c( 0L, 0L)) A simple sparse array of dimension 1x1x4x3. > extend_simple_sparse_array(s, c(-3L, -3L)) A simple sparse array of dimension 4x3x1x1. > > ## automatic > z <- abind_simple_sparse_array(s, 1:3) > z A simple sparse array of dimension 5x3. > all.equal(as.array(z), rbind(x, 1:3)) [1] "Attributes: < Component \"dimnames\": names for target but not for current >" > z <- abind_simple_sparse_array(1:4, s, MARGIN = 2L) > z A simple sparse array of dimension 4x4. > all.equal(as.array(z), cbind(1:4, x)) [1] "Attributes: < Component \"dimnames\": names for target but not for current >" > > abind_simple_sparse_array(1:3, array(2:4, c(1,3)), array(3:8, c(1,2,3))) A simple sparse array of dimension 2x2x3. > abind_simple_sparse_array(1:3, array(2:4, c(3,1)), array(3:8, c(3,2,1)), MARGIN = 3L) A simple sparse array of dimension 3x2x2. > > ## manual > abind_simple_sparse_array(1:3, 2:4) A simple sparse array of dimension 6. > abind_simple_sparse_array(1:3, 2:4, MARGIN = -1L) A simple sparse array of dimension 2x3. > abind_simple_sparse_array(1:3, 2:4, MARGIN = -2L) A simple sparse array of dimension 3x2. > > ### > > proc.time() user system elapsed 0.320 0.016 0.336 slam/tests/stm_zeros.Rout.save0000644000175100001440000001043311320333436016222 0ustar hornikusers R version 2.10.1 Patched (2010-01-01 r50884) Copyright (C) 2010 The R Foundation for Statistical Computing ISBN 3-900051-07-0 R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > set.seed(20091012) > > > ### > as.simple_triplet_matrix_zeros <- + function(x) { + x <- list( + i = rep(seq_len(nrow(x)), ncol(x)), + j = rep(seq_len(ncol(x)), each = nrow(x)), + v = c(x), + nrow = nrow(x), + ncol = ncol(x), + dimnames = dimnames(x) + ) + class(x) <- "simple_triplet_matrix" + x + } > > x <- sample(0:5, 100, T, prob=c(.8,rep(.04,5))) > x <- matrix(as.logical(x), nrow = 20, + dimnames = list(rows = 1:20, cols = LETTERS[1:5])) > x cols rows A B C D E 1 FALSE FALSE FALSE FALSE FALSE 2 FALSE FALSE FALSE FALSE FALSE 3 FALSE FALSE FALSE FALSE TRUE 4 FALSE FALSE FALSE TRUE FALSE 5 FALSE FALSE FALSE FALSE FALSE 6 TRUE FALSE FALSE FALSE FALSE 7 FALSE FALSE FALSE FALSE FALSE 8 TRUE TRUE FALSE FALSE FALSE 9 FALSE FALSE TRUE FALSE FALSE 10 TRUE FALSE FALSE FALSE FALSE 11 FALSE FALSE FALSE TRUE FALSE 12 FALSE FALSE FALSE FALSE FALSE 13 FALSE FALSE FALSE FALSE TRUE 14 FALSE FALSE FALSE FALSE FALSE 15 FALSE TRUE FALSE TRUE TRUE 16 FALSE FALSE TRUE TRUE TRUE 17 FALSE TRUE FALSE FALSE FALSE 18 FALSE FALSE FALSE TRUE FALSE 19 FALSE TRUE FALSE FALSE FALSE 20 FALSE FALSE FALSE FALSE FALSE > > xst <- as.simple_triplet_matrix_zeros(x) > xst A 20x5 simple triplet matrix. > > identical(rowSums(x), row_sums(xst)) [1] TRUE > identical(colSums(x), col_sums(xst)) [1] TRUE > identical(rowMeans(x), row_means(xst)) [1] TRUE > identical(colMeans(x), col_means(xst)) [1] TRUE > > ## NAs > > xna <- x > n <- prod(dim(x)) > is.na(xna) <- sample(seq_len(n), ceiling(n * .1)) > xna cols rows A B C D E 1 FALSE FALSE FALSE NA FALSE 2 FALSE FALSE FALSE FALSE FALSE 3 FALSE FALSE FALSE FALSE TRUE 4 FALSE FALSE FALSE TRUE FALSE 5 FALSE FALSE FALSE FALSE FALSE 6 NA FALSE FALSE FALSE FALSE 7 FALSE NA FALSE FALSE FALSE 8 TRUE TRUE FALSE FALSE FALSE 9 NA FALSE TRUE FALSE FALSE 10 TRUE NA NA FALSE FALSE 11 FALSE FALSE FALSE TRUE FALSE 12 FALSE FALSE FALSE FALSE FALSE 13 FALSE FALSE FALSE FALSE NA 14 FALSE FALSE FALSE FALSE FALSE 15 FALSE TRUE FALSE TRUE TRUE 16 FALSE FALSE NA TRUE TRUE 17 FALSE TRUE FALSE NA FALSE 18 FALSE FALSE FALSE TRUE FALSE 19 FALSE TRUE FALSE FALSE NA 20 FALSE FALSE FALSE FALSE FALSE > > xnast <- as.simple_triplet_matrix_zeros(xna) > xnast A 20x5 simple triplet matrix. > > identical(rowSums(xna), row_sums(xnast)) [1] TRUE > identical(colSums(xna), col_sums(xnast)) [1] TRUE > identical(rowMeans(xna), row_means(xnast)) [1] TRUE > identical(colMeans(xna), col_means(xnast)) [1] TRUE > > identical(rowSums(xna, na.rm = TRUE), row_sums(xnast, na.rm = TRUE)) [1] TRUE > identical(colSums(xna, na.rm = TRUE), col_sums(xnast, na.rm = TRUE)) [1] TRUE > identical(rowMeans(xna, na.rm = TRUE), row_means(xnast, na.rm = TRUE)) [1] TRUE > identical(colMeans(xna, na.rm = TRUE), col_means(xnast, na.rm = TRUE)) [1] TRUE > > ## cross-product > > identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(xst)) [1] TRUE > identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(xst, x)) [1] TRUE > > x <- matrix(c(1, 0, 0, 2, 1, NA), nrow = 3) > x [,1] [,2] [1,] 1 2 [2,] 0 1 [3,] 0 NA > s <- as.simple_triplet_matrix_zeros(x) > > identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(s)) [1] TRUE > identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(s, x)) [1] TRUE > > ## > identical(as.matrix(s * x), x * x) [1] TRUE > identical(as.matrix(x * s), x * x) [1] TRUE > identical(as.matrix(s * s), x * x) [1] TRUE > > identical(as.matrix(s + s), x + x) [1] TRUE > > ### > > > slam/tests/matrix_dimnames.R0000644000175100001440000000063311502441401015664 0ustar hornikusers library("slam") x <- simple_triplet_diag_matrix(1, nrow = 3L) rownames(x) <- letters[1:3] identical(as.matrix(cbind(x, x)), cbind(as.matrix(x), as.matrix(x))) identical(as.matrix(rbind(t(x), t(x))), rbind(as.matrix(t(x)), as.matrix(t(x)))) identical(as.matrix(cbind(x, t(x))), cbind(as.matrix(x), as.matrix(t(x)))) identical(as.matrix(rbind(t(x), x)), rbind(as.matrix(t(x)), as.matrix(x))) ### slam/tests/ssa_valid.Rout.save0000644000175100001440000000247111756200567016160 0ustar hornikusers R version 2.14.2 Patched (2012-02-29 r58546) Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > ## > library(slam) > > ## zero dimension > a <- as.simple_sparse_array(array(0L, 0L)) > drop_simple_sparse_array(a) integer(0) > > ## invalid > a <- simple_sparse_array(rep(1L, 2L), c(1L, -1L)) > a <- reduce_simple_sparse_array(a) Warning message: In reduce_simple_sparse_array(a) : NAs introduced by reduction > as.array(a) [1] NA > > ## not minimal > x <- matrix(1:6, 3L, 2, dimnames = list(NULL, NULL)) > a <- as.simple_sparse_array(x) > z <- reduce_simple_sparse_array(a) > identical(a, z) [1] FALSE > > ## > v <- c("logical", "integer", "double", "complex", "character", "list") > stopifnot(any(sapply(v, function(v) + !.Call("__valid_v", vector(typeof(v), 1L))))) > > ## > slam/tests/subassign.Rout.save0000644000175100001440000001172012231145134016171 0ustar hornikusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: i686-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > ## > library("slam") > ## sparse > x <- simple_sparse_zero_array(dim = c(3, 4, 2)) > ## removal of subscripts > k <- matrix(c(2, 1, 1, 0, 1, 1), c(2, 3), byrow = TRUE) > k [,1] [,2] [,3] [1,] 2 1 1 [2,] 0 1 1 > x[k] <- 1 > x[3, 1, 1] <- 2 > x[c(17, 17)] <- c(2, 3) ## duplicate subscripts > x[c(5, NA, 6)] <- 4 ## recycling > data.frame(v = x$v, i = x$i, + k = .Call("_vector_index", x$dim, x$i)) v i.1 i.2 i.3 k 1 1 2 1 1 2 2 2 3 1 1 3 3 3 2 2 2 17 4 4 2 2 1 5 5 4 3 2 1 6 > > ## > x[, -1, 1] <- 0 ## zero elements > data.frame(v = x$v, i = x$i, + k = .Call("_vector_index", x$dim, x$i)) v i.1 i.2 i.3 k 1 1 2 1 1 2 2 2 3 1 1 3 3 3 2 2 2 17 > x[-c(2, 3)] <- 0 > data.frame(v = x$v, i = x$i, + k = .Call("_vector_index", x$dim, x$i)) v i.1 i.2 i.3 k 1 1 2 1 1 2 2 2 3 1 1 3 > > x[] <- 0 > str(x) List of 4 $ i : int[0 , 1:3] $ v : num(0) $ dim : int [1:3] 3 4 2 $ dimnames: NULL - attr(*, "class")= chr "simple_sparse_array" > > ## misc > x[integer()] <- 1 > x[matrix(integer(), nrow = 0, ncol = 3)] <- 1 > str(x) List of 4 $ i : int[0 , 1:3] $ v : num(0) $ dim : int [1:3] 3 4 2 $ dimnames: NULL - attr(*, "class")= chr "simple_sparse_array" > > try(x[c(NA, 2, 3)] <- 1:2) ## not allowed Error in `[<-.simple_sparse_array`(`*tmp*`, c(NA, 2, 3), value = 1:2) : NAs are not allowed in subscripted assignments > ## works with R >= 3.x > try(x[-c(.Machine$integer.max + 1, 1)] <- c(1, 2)) Warning message: In `[<-.simple_sparse_array`(`*tmp*`, -c(.Machine$integer.max + : number of items to replace is not a multiple of replacement length > > > ## reference > x <- matrix(1:6, nrow = 3) > > ## matrix indexing > k <- matrix(c(1, 1, 2, 2, 1, 1), ncol = 2, byrow = TRUE) > k [,1] [,2] [1,] 1 1 [2,] 2 2 [3,] 1 1 > > z <- x > z[k] <- -1 > z [,1] [,2] [1,] -1 4 [2,] 2 -1 [3,] 3 6 > > z <- x > z[k] <- -(1:3) ## last in sequence > z [,1] [,2] [1,] -3 4 [2,] 2 -2 [3,] 3 6 > > ## implicit vector indexing > k <- matrix(k, nrow = 2) > as.vector(k) [1] 1 2 1 1 2 1 > > z <- x > z[k] <- -1 > z [,1] [,2] [1,] -1 4 [2,] -1 5 [3,] 3 6 > > z <- x > z[k] <- -(1:6) ## last in sequence > z [,1] [,2] [1,] -6 4 [2,] -5 5 [3,] 3 6 > > ## missing values > z <- x > z[c(NA, 1, 2)] <- -1 > z [,1] [,2] [1,] -1 4 [2,] -1 5 [3,] 3 6 > > z <- x > try(z[c(NA, 1, 2)] <- -(1:2)) ## not allowed Error in z[c(NA, 1, 2)] <- -(1:2) : NAs are not allowed in subscripted assignments > > k[1L] <- NA ## implicit vector indexing > as.vector(k) [1] NA 2 1 1 2 1 > z <- x > z[k] <- -1 > z [,1] [,2] [1,] -1 4 [2,] -1 5 [3,] 3 6 > > k <- matrix(c(NA, 1, 1, 1, 2, 2), ncol = 2, byrow = TRUE) > k [,1] [,2] [1,] NA 1 [2,] 1 1 [3,] 2 2 > > z <- x > z[k] <- -1 > z [,1] [,2] [1,] -1 4 [2,] 2 -1 [3,] 3 6 > > z <- x > try(z[k] <- -(1:2)) ## not allowed Error in z[k] <- -(1:2) : NAs are not allowed in subscripted assignments > > ## zeros > z <- x > z[c(0, 1)] <- -1 > z [,1] [,2] [1,] -1 4 [2,] 2 5 [3,] 3 6 > > z <- x > z[c(0, 1)] <- -(1:2) Warning message: In z[c(0, 1)] <- -(1:2) : number of items to replace is not a multiple of replacement length > z [,1] [,2] [1,] -1 4 [2,] 2 5 [3,] 3 6 > > k <- matrix(c(1, 1, 0, 2), ncol = 2, byrow = TRUE) > k [,1] [,2] [1,] 1 1 [2,] 0 2 > > z <- x > z[k] <- -1 > z [,1] [,2] [1,] -1 4 [2,] 2 5 [3,] 3 6 > > z <- x > z[k] <- -(1:2) Warning message: In z[k] <- -(1:2) : number of items to replace is not a multiple of replacement length > z [,1] [,2] [1,] -1 4 [2,] 2 5 [3,] 3 6 > > ## extending > k <- matrix(c(1, 4), ncol = 2) > > z <- x > try(z[k] <- 1) ## not allowed Error in z[k] <- 1 : subscript out of bounds > > z[c(1, 8)] <- 1 ## not implemented > z [1] 1 2 3 4 5 6 NA 1 > > ## misc > z <- x > try(z[-c(.Machine$integer.max + 1, 1)] <- c(1, 2)) Warning message: In z[-c(.Machine$integer.max + 1, 1)] <- c(1, 2) : number of items to replace is not a multiple of replacement length > > ### > > proc.time() user system elapsed 0.356 0.036 0.385 slam/tests/stm_ttcrossprod.Rout.save0000644000175100001440000000243211443342170017447 0ustar hornikusers R version 2.11.1 Patched (2010-09-04 r52871) Copyright (C) 2010 The R Foundation for Statistical Computing ISBN 3-900051-07-0 R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > > ## test > x <- matrix(c(1, 0, 0, 2, 1, 0), nrow = 3, + dimnames = list(A = 1:3, B = 1:2)) > s <- as.simple_triplet_matrix(x) > dimnames(x)[[1L]] <- letters[1:3] > names(dimnames(x))[1L] <- 1 > x B 1 1 2 a 1 2 b 0 1 c 0 0 > > ## > z <- tcrossprod_simple_triplet_matrix(s, x[1:2,]) > z 1 A a b 1 5 2 2 2 1 3 0 0 > > zz <- slam:::.ttcrossprod_simple_triplet_matrix(s, x[1:2,]) > identical(z, t(zz)) [1] TRUE > > ## bailout > is.na(x) <- 4L > > z <- tcrossprod_simple_triplet_matrix(s, x[1:2,]) > z 1 A a b 1 NA 2 2 NA 1 3 NA 0 > > zz <- slam:::.ttcrossprod_simple_triplet_matrix(s, x[1:2,]) > identical(z, t(zz)) [1] TRUE > > ### > slam/tests/stm_apply.Rout.save0000644000175100001440000000313612262760225016215 0ustar hornikusers R version 2.14.2 Patched (2012-02-29 r58546) Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > ## > require("slam") Loading required package: slam > > ## > x <- matrix(c(1L, 0L, 3L, 0L, 5L, 0L), ncol = 2, + dimnames = list(1:3, LETTERS[1:2])) > x A B 1 1 0 2 0 5 3 3 0 > s <- as.simple_triplet_matrix(x) > > colapply_simple_triplet_matrix(s, identity) $A [1] 1 0 3 $B [1] 0 5 0 > rowapply_simple_triplet_matrix(s, identity) $`1` [1] 1 0 $`2` [1] 0 5 $`3` [1] 3 0 > > s$v <- as.numeric(s$v) > simplify2array(colapply_simple_triplet_matrix(s, identity)) A B [1,] 1 0 [2,] 0 5 [3,] 3 0 > > s$v <- as.complex(s$v) > simplify2array(colapply_simple_triplet_matrix(s, identity)) A B [1,] 1+0i 0+0i [2,] 0+0i 5+0i [3,] 3+0i 0+0i > > s$v <- as.list(s$v) > simplify2array(colapply_simple_triplet_matrix(s, identity)) A B [1,] 1+0i NULL [2,] NULL 5+0i [3,] 3+0i NULL > > s$v <- as.character(s$v) > simplify2array(colapply_simple_triplet_matrix(s, identity)) A B [1,] "1+0i" "" [2,] "" "5+0i" [3,] "3+0i" "" > > ## > slam/tests/dimgets.R0000644000175100001440000000075012262026562014152 0ustar hornikusersrequire("slam") x <- matrix(1 : 8, 2, 4) dimnames(x) <- list(ROW = LETTERS[seq_len(nrow(x))], COL = letters[seq_len(ncol(x))]) s <- as.simple_triplet_matrix(x) dim(s) <- dim(x) <- c(4, 2) stopifnot(identical(as.matrix(s), x)) d <- c(2, 3, 4) x <- array(seq_len(prod(d)), d) s <- as.simple_sparse_array(x) dim(s) <- dim(x) <- c(d[length(d)], d[-length(d)]) stopifnot(identical(as.array(s), x)) dimnames(s) <- dimnames(x) <- NULL stopifnot(identical(as.array(s), x)) slam/tests/stm.Rout.save0000644000175100001440000001050212231011101014755 0ustar hornikusers R version 2.14.2 Patched (2012-02-29 r58546) Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > set.seed(20090626) > > ### > > x <- sample(0:5, 100, T, prob=c(.8,rep(.04,5))) > x <- matrix(as.logical(x), nrow = 20, + dimnames = list(rows = 1:20, cols = LETTERS[1:5])) > x cols rows A B C D E 1 TRUE FALSE FALSE FALSE FALSE 2 TRUE FALSE FALSE FALSE TRUE 3 FALSE TRUE FALSE FALSE FALSE 4 FALSE FALSE FALSE FALSE TRUE 5 FALSE FALSE FALSE FALSE FALSE 6 FALSE FALSE FALSE TRUE FALSE 7 FALSE FALSE FALSE FALSE FALSE 8 FALSE FALSE FALSE FALSE FALSE 9 FALSE TRUE FALSE FALSE FALSE 10 TRUE FALSE FALSE TRUE FALSE 11 FALSE FALSE FALSE FALSE FALSE 12 TRUE TRUE FALSE FALSE FALSE 13 FALSE TRUE FALSE FALSE FALSE 14 FALSE FALSE FALSE FALSE FALSE 15 TRUE TRUE TRUE FALSE FALSE 16 FALSE TRUE FALSE FALSE FALSE 17 FALSE FALSE FALSE FALSE FALSE 18 FALSE FALSE FALSE FALSE FALSE 19 FALSE FALSE TRUE FALSE FALSE 20 TRUE FALSE FALSE FALSE FALSE > > xst <- as.simple_triplet_matrix(x) > xst A 20x5 simple triplet matrix. > > identical(rowSums(x), row_sums(xst)) [1] TRUE > identical(colSums(x), col_sums(xst)) [1] TRUE > identical(rowMeans(x), row_means(xst)) [1] TRUE > identical(colMeans(x), col_means(xst)) [1] TRUE > > ## NAs > > xna <- x > n <- prod(dim(x)) > is.na(xna) <- sample(seq_len(n), ceiling(n * .1)) > xna cols rows A B C D E 1 TRUE FALSE FALSE FALSE FALSE 2 TRUE FALSE FALSE FALSE TRUE 3 FALSE NA FALSE FALSE FALSE 4 FALSE NA FALSE FALSE TRUE 5 FALSE FALSE FALSE FALSE FALSE 6 FALSE NA FALSE NA FALSE 7 FALSE FALSE FALSE FALSE FALSE 8 FALSE FALSE FALSE FALSE FALSE 9 FALSE TRUE FALSE FALSE FALSE 10 TRUE FALSE FALSE TRUE FALSE 11 NA FALSE FALSE FALSE FALSE 12 TRUE NA FALSE FALSE FALSE 13 FALSE TRUE FALSE FALSE FALSE 14 FALSE FALSE FALSE FALSE NA 15 TRUE NA TRUE FALSE FALSE 16 FALSE TRUE FALSE FALSE FALSE 17 FALSE FALSE FALSE FALSE FALSE 18 FALSE FALSE FALSE FALSE FALSE 19 FALSE FALSE TRUE FALSE FALSE 20 TRUE FALSE NA NA FALSE > > xnast <- as.simple_triplet_matrix(xna) > xnast A 20x5 simple triplet matrix. > > ## default method > identical(rowSums(xna), row_sums(xna)) [1] TRUE > identical(colSums(xna), col_sums(xna)) [1] TRUE > identical(rowMeans(xna), row_means(xna)) [1] TRUE > identical(colMeans(xna), col_means(xna)) [1] TRUE > > identical(rowSums(xna), row_sums(xnast)) [1] TRUE > identical(colSums(xna), col_sums(xnast)) [1] TRUE > identical(rowMeans(xna), row_means(xnast)) [1] TRUE > identical(colMeans(xna), col_means(xnast)) [1] TRUE > > identical(rowSums(xna, na.rm = TRUE), row_sums(xnast, na.rm = TRUE)) [1] TRUE > identical(colSums(xna, na.rm = TRUE), col_sums(xnast, na.rm = TRUE)) [1] TRUE > identical(rowMeans(xna, na.rm = TRUE), row_means(xnast, na.rm = TRUE)) [1] TRUE > identical(colMeans(xna, na.rm = TRUE), col_means(xnast, na.rm = TRUE)) [1] TRUE > > ## cross-product > > identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(xst)) [1] TRUE > identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(xst, x)) [1] TRUE > identical(tcrossprod(x[1:10,], x[11:20,]), + tcrossprod_simple_triplet_matrix(xst[1:10,], xst[11:20,])) [1] TRUE > > x <- matrix(c(1, 0, 0, 2, 1, NA), nrow = 3) > x [,1] [,2] [1,] 1 2 [2,] 0 1 [3,] 0 NA > s <- as.simple_triplet_matrix(x) > > identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(s)) [1] TRUE > identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(s, x)) [1] TRUE > identical(tcrossprod(x[2:3,], x[1,, drop = FALSE]), + tcrossprod_simple_triplet_matrix(s[2:3,], s[1,])) [1] TRUE > identical(tcrossprod(x[1,, drop = FALSE], x[2:3,]), + tcrossprod_simple_triplet_matrix(s[1,], s[2:3,])) [1] TRUE > > ### > > > slam/tests/util.Rout.save0000644000175100001440000001107312031761434015156 0ustar hornikusers R version 2.14.2 Patched (2012-02-29 r58546) Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > > ## > .Call("_part_index", factor(1:4)) [1] 1 1 1 1 attr(,"table") [1] 1 1 1 1 > .Call("_part_index", factor(c(1L,2L,2L,1L))) [1] 1 1 2 2 attr(,"table") [1] 2 2 > .Call("_part_index", factor(c(1L,2L,NA,1L))) [1] 1 1 NA 2 attr(,"table") [1] 2 1 > > ## > i <- 1:27 > x <- arrayInd(i, .dim = c(3L,3L,3L)) > .Call("_vector_index", c(3L,3L,3L), x) [1] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 [26] 26 27 > x[14L, 2L] <- NA > .Call("_vector_index", c(3L,3L,3L), x) [1] 1 2 3 4 5 6 7 8 9 10 11 12 13 NA 15 16 17 18 19 20 21 22 23 24 25 [26] 26 27 > > ## > v <- c(1L,1L) > p <- matrix(c(1L,2L,3L, 2L,2L,2L), nrow = 2L, byrow = TRUE) > .Call("_ini_array", c(3L,3L,3L), p, v, 2L) , , 1 [,1] [,2] [,3] [1,] 0 0 0 [2,] 0 0 0 [3,] 0 0 0 , , 2 [,1] [,2] [,3] [1,] 0 0 0 [2,] 0 1 0 [3,] 0 0 0 , , 3 [,1] [,2] [,3] [1,] 0 0 0 [2,] 0 0 0 [3,] 0 0 0 > .Call("_ini_array", c(3L,3L,3L), p, as.logical(v), 2L) , , 1 [,1] [,2] [,3] [1,] FALSE FALSE FALSE [2,] FALSE FALSE FALSE [3,] FALSE FALSE FALSE , , 2 [,1] [,2] [,3] [1,] FALSE FALSE FALSE [2,] FALSE TRUE FALSE [3,] FALSE FALSE FALSE , , 3 [,1] [,2] [,3] [1,] FALSE FALSE FALSE [2,] FALSE FALSE FALSE [3,] FALSE FALSE FALSE > .Call("_ini_array", c(3L,3L,3L), p, as.double(v), 2L) , , 1 [,1] [,2] [,3] [1,] 0 0 0 [2,] 0 0 0 [3,] 0 0 0 , , 2 [,1] [,2] [,3] [1,] 0 0 0 [2,] 0 1 0 [3,] 0 0 0 , , 3 [,1] [,2] [,3] [1,] 0 0 0 [2,] 0 0 0 [3,] 0 0 0 > .Call("_ini_array", c(3L,3L,3L), p, as.raw(v), 2L) , , 1 [,1] [,2] [,3] [1,] 00 00 00 [2,] 00 00 00 [3,] 00 00 00 , , 2 [,1] [,2] [,3] [1,] 00 00 00 [2,] 00 01 00 [3,] 00 00 00 , , 3 [,1] [,2] [,3] [1,] 00 00 00 [2,] 00 00 00 [3,] 00 00 00 > .Call("_ini_array", c(3L,3L,3L), p, as.complex(v), 2L) , , 1 [,1] [,2] [,3] [1,] 0+0i 0+0i 0+0i [2,] 0+0i 0+0i 0+0i [3,] 0+0i 0+0i 0+0i , , 2 [,1] [,2] [,3] [1,] 0+0i 0+0i 0+0i [2,] 0+0i 1+0i 0+0i [3,] 0+0i 0+0i 0+0i , , 3 [,1] [,2] [,3] [1,] 0+0i 0+0i 0+0i [2,] 0+0i 0+0i 0+0i [3,] 0+0i 0+0i 0+0i > .Call("_ini_array", c(3L,3L,3L), p, as.character(v), 2L) , , 1 [,1] [,2] [,3] [1,] "" "" "" [2,] "" "" "" [3,] "" "" "" , , 2 [,1] [,2] [,3] [1,] "" "" "" [2,] "" "1" "" [3,] "" "" "" , , 3 [,1] [,2] [,3] [1,] "" "" "" [2,] "" "" "" [3,] "" "" "" > .Call("_ini_array", c(3L,3L,3L), p, as.list(v), 2L) , , 1 [,1] [,2] [,3] [1,] NULL NULL NULL [2,] NULL NULL NULL [3,] NULL NULL NULL , , 2 [,1] [,2] [,3] [1,] NULL NULL NULL [2,] NULL 1 NULL [3,] NULL NULL NULL , , 3 [,1] [,2] [,3] [1,] NULL NULL NULL [2,] NULL NULL NULL [3,] NULL NULL NULL > .Call("_ini_array", c(3L,3L,3L), p, as.expression(v), 2L) expression(NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, 1L, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL) > > .Call("_ini_array", 3L, c(1L,2L), c(1L,1L), 2L) [1] 0 1 0 > > .Call("_split_col", array(c(1L,2L), c(2L, 2L))) [[1]] [1] 1 2 [[2]] [1] 1 2 > > ## > x <- matrix(c(1L,1L,1L,1L,1L,2L,1L,3L,1L,2L), + ncol = 2, byrow = TRUE) > x [,1] [,2] [1,] 1 1 [2,] 1 1 [3,] 1 2 [4,] 1 3 [5,] 1 2 > .Call("_match_matrix", x, NULL, NULL) [[1]] [1] 1 1 2 3 2 [[2]] [1] 1 3 4 > .Call("_match_matrix", x, x[1:3,], 0L) [[1]] [1] 1 1 2 3 2 [[2]] [1] 1 1 2 > > > ## > x <- matrix(c(1L,2L,2L,2L,NA,1L,NA,2L,NA,NA), + ncol = 2, byrow = TRUE) > x [,1] [,2] [1,] 1 2 [2,] 2 2 [3,] NA 1 [4,] NA 2 [5,] NA NA > .Call("_all_row", x > 1L, FALSE) [1] FALSE TRUE NA NA NA > .Call("_all_row", x > 1L, TRUE) [1] FALSE TRUE FALSE TRUE TRUE > > ### > slam/tests/stm_subassign.R0000644000175100001440000000055012103507072015367 0ustar hornikusers ## library("slam") s <- as.simple_triplet_matrix(diag(4)) s[1:8] <- 1:8 as.matrix(s) s[2:3,] <- 1:8 as.matrix(s) s[,2:3] <- 1:8 as.matrix(s) s[] <- 1:8 as.matrix(s) ## local({ k <- 2:3 ## Implementing class. a <- as.simple_sparse_array(s) a[,k] a[,k] <- 1:8 s[,k] <- 1:8 stopifnot(identical(as.array(a), as.array(s))) }) ### slam/tests/subassign.R0000644000175100001440000000341412231145134014505 0ustar hornikusers## library("slam") ## sparse x <- simple_sparse_zero_array(dim = c(3, 4, 2)) ## removal of subscripts k <- matrix(c(2, 1, 1, 0, 1, 1), c(2, 3), byrow = TRUE) k x[k] <- 1 x[3, 1, 1] <- 2 x[c(17, 17)] <- c(2, 3) ## duplicate subscripts x[c(5, NA, 6)] <- 4 ## recycling data.frame(v = x$v, i = x$i, k = .Call("_vector_index", x$dim, x$i)) ## x[, -1, 1] <- 0 ## zero elements data.frame(v = x$v, i = x$i, k = .Call("_vector_index", x$dim, x$i)) x[-c(2, 3)] <- 0 data.frame(v = x$v, i = x$i, k = .Call("_vector_index", x$dim, x$i)) x[] <- 0 str(x) ## misc x[integer()] <- 1 x[matrix(integer(), nrow = 0, ncol = 3)] <- 1 str(x) try(x[c(NA, 2, 3)] <- 1:2) ## not allowed ## works with R >= 3.x try(x[-c(.Machine$integer.max + 1, 1)] <- c(1, 2)) ## reference x <- matrix(1:6, nrow = 3) ## matrix indexing k <- matrix(c(1, 1, 2, 2, 1, 1), ncol = 2, byrow = TRUE) k z <- x z[k] <- -1 z z <- x z[k] <- -(1:3) ## last in sequence z ## implicit vector indexing k <- matrix(k, nrow = 2) as.vector(k) z <- x z[k] <- -1 z z <- x z[k] <- -(1:6) ## last in sequence z ## missing values z <- x z[c(NA, 1, 2)] <- -1 z z <- x try(z[c(NA, 1, 2)] <- -(1:2)) ## not allowed k[1L] <- NA ## implicit vector indexing as.vector(k) z <- x z[k] <- -1 z k <- matrix(c(NA, 1, 1, 1, 2, 2), ncol = 2, byrow = TRUE) k z <- x z[k] <- -1 z z <- x try(z[k] <- -(1:2)) ## not allowed ## zeros z <- x z[c(0, 1)] <- -1 z z <- x z[c(0, 1)] <- -(1:2) z k <- matrix(c(1, 1, 0, 2), ncol = 2, byrow = TRUE) k z <- x z[k] <- -1 z z <- x z[k] <- -(1:2) z ## extending k <- matrix(c(1, 4), ncol = 2) z <- x try(z[k] <- 1) ## not allowed z[c(1, 8)] <- 1 ## not implemented z ## misc z <- x try(z[-c(.Machine$integer.max + 1, 1)] <- c(1, 2)) ### slam/tests/apply.R0000644000175100001440000000353012262026562013642 0ustar hornikusers library("slam") set.seed(201311) ### x <- matrix(rnorm(100), nrow = 20, dimnames = list(1:20, LETTERS[1:5]) ) x[sample(100, 80)] <- 0 s <- as.simple_triplet_matrix(x) s ## identical(apply(x, 2L, var), colapply_simple_triplet_matrix(s, var)) identical(apply(x, 1L, var), rowapply_simple_triplet_matrix(s, var)) ## k <- 1:2 z <- var(x[, k], x[, -k]) identical(z, crossapply_simple_triplet_matrix(s[, k], s[, -k], FUN = var)) identical(z, crossapply_simple_triplet_matrix(x[, k], s[, -k], FUN = var)) identical(z, tcrossapply_simple_triplet_matrix(t(s[, k]), t(s[, -k]), FUN = var)) identical(z, tcrossapply_simple_triplet_matrix(t(x[, k]), t(s[, -k]), FUN = var)) z <- var(x) identical(z, crossapply_simple_triplet_matrix(s, FUN = var)) ## null-dimensions z <- var(x[, 0], x) z all.equal(z, crossapply_simple_triplet_matrix(s[, 0], s, FUN = var)) all.equal(z, crossapply_simple_triplet_matrix(x[, 0], s, FUN = var)) try(crossapply_simple_triplet_matrix(x[, 0], s, FUN = var, use = "all.obs")) z <- var(x, x[, 0]) z all.equal(z, crossapply_simple_triplet_matrix(s, s[, 0], FUN = var)) all.equal(z, crossapply_simple_triplet_matrix(x, s[, 0], FUN = var)) z <- var(x[, 0]) z all.equal(z, crossapply_simple_triplet_matrix(s[, 0], s[, 0], FUN = var)) all.equal(z, crossapply_simple_triplet_matrix(x[, 0], s[, 0], FUN = var)) all.equal(z, crossapply_simple_triplet_matrix(s[, 0], FUN = var)) z <- var(x[0, ]) z all.equal(z, crossapply_simple_triplet_matrix(s[0, ], s[0, ], FUN = var)) all.equal(z, crossapply_simple_triplet_matrix(x[0, ], s[0, ], FUN = var)) all.equal(z, crossapply_simple_triplet_matrix(s[0, ], FUN = var)) ## non-scalar z <- crossapply_simple_triplet_matrix(s, s, FUN = ">") all.equal(z, crossapply_simple_triplet_matrix(x, s, FUN = ">")) all.equal(z[lower.tri(z)], crossapply_simple_triplet_matrix(s, FUN = ">")[lower.tri(z)]) ### slam/tests/matrix_dimnames.Rout.save0000644000175100001440000000214611502441401017352 0ustar hornikusers R version 2.12.0 Patched (2010-12-05 r53790) Copyright (C) 2010 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > > x <- simple_triplet_diag_matrix(1, nrow = 3L) > rownames(x) <- letters[1:3] > > identical(as.matrix(cbind(x, x)), + cbind(as.matrix(x), as.matrix(x))) [1] TRUE > identical(as.matrix(rbind(t(x), t(x))), + rbind(as.matrix(t(x)), as.matrix(t(x)))) [1] TRUE > > identical(as.matrix(cbind(x, t(x))), + cbind(as.matrix(x), as.matrix(t(x)))) [1] TRUE > identical(as.matrix(rbind(t(x), x)), + rbind(as.matrix(t(x)), as.matrix(x))) [1] TRUE > > ### > slam/tests/stm_valid.R0000644000175100001440000000034711527416634014510 0ustar hornikusers library("slam") set.seed(20110217) ### x <- matrix(sample(c(0,1), 12, TRUE), ncol = 3L) s <- as.simple_triplet_matrix(x) s ## make invalid row indexes s$i[sample(seq_along(s$i), 3)] <- 0L try(row_sums(s), silent = FALSE) ### slam/tests/crossprod.Rout.save0000644000175100001440000000347112254246630016225 0ustar hornikusers R version 2.14.2 Patched (2012-02-29 r58546) Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > > ## > x <- matrix(c(1, 0, 0, 2, 1, 0), nrow = 3) > x [,1] [,2] [1,] 1 2 [2,] 0 1 [3,] 0 0 > sx <- as.simple_triplet_matrix(x) > > y <- matrix(1:6, nrow = 3) > sy <- as.simple_triplet_matrix(y) > > identical(tcrossprod(x, y), tcrossprod_simple_triplet_matrix( x, sy)) [1] TRUE > identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(sx)) [1] TRUE > identical(tcrossprod(x, y), tcrossprod_simple_triplet_matrix(sx, sy)) [1] TRUE > identical(tcrossprod(x, y), tcrossprod_simple_triplet_matrix(sx, y)) [1] TRUE > > identical(crossprod(x, y), crossprod_simple_triplet_matrix( x, sy)) [1] TRUE > identical(crossprod(x), crossprod_simple_triplet_matrix(sx)) [1] TRUE > identical(crossprod(x, y), crossprod_simple_triplet_matrix(sx, sy)) [1] TRUE > identical(crossprod(x, y), crossprod_simple_triplet_matrix(sx, y)) [1] TRUE > > identical(crossprod(x, y), matprod_simple_triplet_matrix(t( x), sy)) [1] TRUE > identical(crossprod(x, y), matprod_simple_triplet_matrix(t(sx), sy)) [1] TRUE > identical(crossprod(x, y), matprod_simple_triplet_matrix(t(sx), y)) [1] TRUE > > ## Note that correctness under bailout is covered elsewhere. > > ## > slam/tests/ssa_valid.R0000644000175100001440000000102611756200567014466 0ustar hornikusers ## library(slam) ## zero dimension a <- as.simple_sparse_array(array(0L, 0L)) drop_simple_sparse_array(a) ## invalid a <- simple_sparse_array(rep(1L, 2L), c(1L, -1L)) a <- reduce_simple_sparse_array(a) as.array(a) ## not minimal x <- matrix(1:6, 3L, 2, dimnames = list(NULL, NULL)) a <- as.simple_sparse_array(x) z <- reduce_simple_sparse_array(a) identical(a, z) ## v <- c("logical", "integer", "double", "complex", "character", "list") stopifnot(any(sapply(v, function(v) !.Call("__valid_v", vector(typeof(v), 1L))))) ## slam/tests/crossprod.R0000644000175100001440000000173512254246630014541 0ustar hornikusers library("slam") ## x <- matrix(c(1, 0, 0, 2, 1, 0), nrow = 3) x sx <- as.simple_triplet_matrix(x) y <- matrix(1:6, nrow = 3) sy <- as.simple_triplet_matrix(y) identical(tcrossprod(x, y), tcrossprod_simple_triplet_matrix( x, sy)) identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(sx)) identical(tcrossprod(x, y), tcrossprod_simple_triplet_matrix(sx, sy)) identical(tcrossprod(x, y), tcrossprod_simple_triplet_matrix(sx, y)) identical(crossprod(x, y), crossprod_simple_triplet_matrix( x, sy)) identical(crossprod(x), crossprod_simple_triplet_matrix(sx)) identical(crossprod(x, y), crossprod_simple_triplet_matrix(sx, sy)) identical(crossprod(x, y), crossprod_simple_triplet_matrix(sx, y)) identical(crossprod(x, y), matprod_simple_triplet_matrix(t( x), sy)) identical(crossprod(x, y), matprod_simple_triplet_matrix(t(sx), sy)) identical(crossprod(x, y), matprod_simple_triplet_matrix(t(sx), y)) ## Note that correctness under bailout is covered elsewhere. ## slam/tests/stm_valid.Rout.save0000644000175100001440000000174211527416634016175 0ustar hornikusers R version 2.12.2 beta (2011-02-16 r54449) Copyright (C) 2011 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > set.seed(20110217) > > ### > x <- matrix(sample(c(0,1), 12, TRUE), ncol = 3L) > s <- as.simple_triplet_matrix(x) > s A 4x3 simple triplet matrix. > > ## make invalid row indexes > s$i[sample(seq_along(s$i), 3)] <- 0L > > try(row_sums(s), silent = FALSE) Error in row_sums.simple_triplet_matrix(s) : 'i, j' invalid > > ### > > slam/tests/rollup.Rout.save0000644000175100001440000000452511746150514015525 0ustar hornikusers R version 2.14.2 Patched (2012-02-29 r58546) Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > ## > library("slam") > > ## > x <- matrix(c(1, 0, 0, 2, 1, NA), nrow = 2, + dimnames = list(A = 1:2, B = 1:3)) > x B A 1 2 3 1 1 0 1 2 0 2 NA > > a <- as.simple_sparse_array(x) > a A simple sparse array of dimension 2x3. > > ## > z <- rollup(x, 2L, c(1,2,1), na.rm = TRUE) > z B A 1 2 1 2 0 2 0 2 > identical(as.array(z), + as.array(rollup(a, 2L, c(1,2,1), na.rm = TRUE))) [1] TRUE > identical(as.array(z), + as.array(rollup(a, 2L, c(1,2,1), na.rm = TRUE, EXPAND = "dense"))) processing 3 cells ... [0.00s] [1] TRUE > identical(as.array(z), + as.array(rollup(a, 2L, c(1,2,1), na.rm = TRUE, EXPAND = "all"))) processing 4 cells ... [0.00s] [1] TRUE > > ## > z <- rollup(x, 2L, c(1,NA,1), na.rm = TRUE) > z B A 1 1 2 2 0 > identical(as.array(z), + as.array(rollup(a, 2L, c(1,NA,1), na.rm = TRUE))) [1] TRUE > identical(as.array(z), + as.array(rollup(a, 2L, c(1,NA,1), na.rm = TRUE, EXPAND = "dense"))) processing 2 cells ... [0.00s] [1] TRUE > identical(as.array(z), + as.array(rollup(a, 2L, c(1,NA,1), na.rm = TRUE, EXPAND = "all"))) processing 2 cells ... [0.00s] [1] TRUE > > ## > z <- rollup(x, 2L, c(1,NA,1), na.rm = TRUE, DROP = TRUE) > identical(as.array(z), + as.array(rollup(a, 2L, c(1,NA,1), na.rm = TRUE, DROP = TRUE))) [1] TRUE > > > ## > z <- rollup(x, 1:2, list(1:2, c(1,2,1)), na.rm = TRUE) > identical(as.array(z), + as.array(rollup(a, 1:2, list(1:2, c(1,2,1)), na.rm = TRUE))) [1] TRUE > > ## > s <- as.simple_triplet_matrix(a) > z <- rollup(x, 2L, FUN = min, na.rm = TRUE) > identical(as.matrix(z), + as.matrix(rollup(s, 2L, FUN = min, na.rm = TRUE, EXPAND = "dense"))) processing 2 cells ... [0.00s] [1] TRUE > > ### > slam/tests/extract.R0000644000175100001440000000376412031361105014165 0ustar hornikusers## library("slam") ## x <- simple_sparse_zero_array(dim = c(3, 2)) x[1] x[matrix(c(1, 1), nrow = 1)] ## x <- as.simple_sparse_array(matrix(1:6, ncol = 2)) x[1] x[matrix(c(1, 1), nrow = 1)] x[1.1] ## truncation x[integer()] x[matrix(integer(), ncol = 2)] ## missing values x[c(1, 0, NA, 2)] k <- matrix(c(1, 1, 1, 0, 1, NA), ncol = 2, byrow = TRUE) k x[k] ## wrong dimensions dim(k) <- c(2,3) as.vector(k) x[k] z <- x[c(1,3),] data.frame(v = z$v, i = z$i, k = .Call("_vector_index", z$dim, z$i)) ## drop not implemented x[ 1,] x[-1,] try(x[1, NA_integer_]) ## not implemented str(x[0,]) str(x[0, 0]) x[c(1, 8)] ## out of bounds allowed try(x[1, 8]) ## not allowed dim(k) <- c(3,2) k[6] <- 3 k try(x[k]) ## not allowed ## x <- simple_triplet_zero_matrix(nrow = 3, ncol = 2) x[1] x[matrix(c(1, 1), nrow = 1)] ## x <- as.simple_triplet_matrix(matrix(1:6, ncol = 2)) x[1] x[matrix(c(1, 1), nrow = 1)] x[1.1] ## truncation x[integer()] x[matrix(integer(), ncol = 2)] ## missing values x[c(1, 0, NA, 2)] k <- matrix(c(1, 1, 1, 0, 1, NA), ncol = 2, byrow = TRUE) k x[k] ## wrong dimensions dim(k) <- c(2,3) as.vector(k) x[k] z <- x[c(1,3),] data.frame(v = z$v, i = z$i, j = z$j, k = .Call("_vector_index", c(z$nrow, z$ncol), cbind(z$i, z$j))) ## drop not implemented x[ 1,] x[-1,] try(x[1, NA_integer_]) ## not implemented str(x[0,]) str(x[0, 0]) x[c(1, 8)] ## out of bounds allowed try(x[1, 8]) ## not allowed dim(k) <- c(3,2) k[6] <- 3 k try(x[k]) ## not allowed x[c(TRUE, FALSE)] x[c(TRUE, FALSE),] ## reference x <- matrix(1:6, ncol = 2) x[c(1, 0, NA, 2)] try(x[-c(1, NA)]) ## not allowed ## missing allowed k <- matrix(c(1, 1, 1, 0, 1, NA), ncol = 2, byrow = TRUE) k x[k] dim(k) <- c(2, 3) as.vector(k) x[k] x[ 1,] x[-1,] x[ 1, NA] ## wildcard x[0,] ## does not drop x[0,0] x[c(1, 8)] ## out of bounds allowed try(x[1, 8]) ## not allowed dim(k) <- c(3,2) k[6] <- 3 k try(x[k]) ## not allowed x[c(TRUE, FALSE)] x[c(TRUE, FALSE),] ### slam/tests/util.R0000644000175100001440000000226412031761434013473 0ustar hornikusers library("slam") ## .Call("_part_index", factor(1:4)) .Call("_part_index", factor(c(1L,2L,2L,1L))) .Call("_part_index", factor(c(1L,2L,NA,1L))) ## i <- 1:27 x <- arrayInd(i, .dim = c(3L,3L,3L)) .Call("_vector_index", c(3L,3L,3L), x) x[14L, 2L] <- NA .Call("_vector_index", c(3L,3L,3L), x) ## v <- c(1L,1L) p <- matrix(c(1L,2L,3L, 2L,2L,2L), nrow = 2L, byrow = TRUE) .Call("_ini_array", c(3L,3L,3L), p, v, 2L) .Call("_ini_array", c(3L,3L,3L), p, as.logical(v), 2L) .Call("_ini_array", c(3L,3L,3L), p, as.double(v), 2L) .Call("_ini_array", c(3L,3L,3L), p, as.raw(v), 2L) .Call("_ini_array", c(3L,3L,3L), p, as.complex(v), 2L) .Call("_ini_array", c(3L,3L,3L), p, as.character(v), 2L) .Call("_ini_array", c(3L,3L,3L), p, as.list(v), 2L) .Call("_ini_array", c(3L,3L,3L), p, as.expression(v), 2L) .Call("_ini_array", 3L, c(1L,2L), c(1L,1L), 2L) .Call("_split_col", array(c(1L,2L), c(2L, 2L))) ## x <- matrix(c(1L,1L,1L,1L,1L,2L,1L,3L,1L,2L), ncol = 2, byrow = TRUE) x .Call("_match_matrix", x, NULL, NULL) .Call("_match_matrix", x, x[1:3,], 0L) ## x <- matrix(c(1L,2L,2L,2L,NA,1L,NA,2L,NA,NA), ncol = 2, byrow = TRUE) x .Call("_all_row", x > 1L, FALSE) .Call("_all_row", x > 1L, TRUE) ### slam/tests/abind.R0000644000175100001440000000157411753474631013610 0ustar hornikusers## library("slam") x <- matrix(1:12, 4, dimnames = list(NULL, B = 1:3)) s <- as.simple_sparse_array(x) s extend_simple_sparse_array(s, 0L) extend_simple_sparse_array(s, -1L) ## the same extend_simple_sparse_array(s, 1L) extend_simple_sparse_array(s, 2L) extend_simple_sparse_array(s, -3L) ## the same extend_simple_sparse_array(s, c( 0L, 0L)) extend_simple_sparse_array(s, c(-3L, -3L)) ## automatic z <- abind_simple_sparse_array(s, 1:3) z all.equal(as.array(z), rbind(x, 1:3)) z <- abind_simple_sparse_array(1:4, s, MARGIN = 2L) z all.equal(as.array(z), cbind(1:4, x)) abind_simple_sparse_array(1:3, array(2:4, c(1,3)), array(3:8, c(1,2,3))) abind_simple_sparse_array(1:3, array(2:4, c(3,1)), array(3:8, c(3,2,1)), MARGIN = 3L) ## manual abind_simple_sparse_array(1:3, 2:4) abind_simple_sparse_array(1:3, 2:4, MARGIN = -1L) abind_simple_sparse_array(1:3, 2:4, MARGIN = -2L) ### slam/tests/stm_ttcrossprod.R0000644000175100001440000000077511443342170015772 0ustar hornikusers library("slam") ## test x <- matrix(c(1, 0, 0, 2, 1, 0), nrow = 3, dimnames = list(A = 1:3, B = 1:2)) s <- as.simple_triplet_matrix(x) dimnames(x)[[1L]] <- letters[1:3] names(dimnames(x))[1L] <- 1 x ## z <- tcrossprod_simple_triplet_matrix(s, x[1:2,]) z zz <- slam:::.ttcrossprod_simple_triplet_matrix(s, x[1:2,]) identical(z, t(zz)) ## bailout is.na(x) <- 4L z <- tcrossprod_simple_triplet_matrix(s, x[1:2,]) z zz <- slam:::.ttcrossprod_simple_triplet_matrix(s, x[1:2,]) identical(z, t(zz)) ### slam/tests/matrix.Rout.save0000644000175100001440000000276511314667363015526 0ustar hornikusers R version 2.10.1 Patched (2009-12-21 r50815) Copyright (C) 2009 The R Foundation for Statistical Computing ISBN 3-900051-07-0 R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > > s <- simple_triplet_diag_matrix(1, nrow = 3) > > identical(as.matrix(s) * Inf, as.matrix(s * Inf)) [1] TRUE > identical(as.matrix(s) * NA, as.matrix(s * NA_real_)) [1] TRUE > > identical(as.matrix(s) * c(Inf, NA, 0), as.matrix(s * c(Inf, NA, 0))) [1] TRUE > > x1 <- matrix(c(1, Inf, 0, 1), nrow = 2) > x2 <- matrix(c(1, 0, NA, 1), nrow = 2) > > identical(x1 * x2, as.matrix(as.simple_triplet_matrix(x1) * x2)) [1] TRUE > identical(x1 * x2, as.matrix(as.simple_triplet_matrix(x1) * + as.simple_triplet_matrix(x2))) [1] TRUE > > x <- matrix(1, nrow = 3, ncol = 3) > identical(x * as.matrix(s), as.matrix(s * as.simple_triplet_matrix(x))) [1] TRUE > identical(x / as.matrix(s), as.matrix(as.simple_triplet_matrix(x) / s)) [1] TRUE > > identical(x * as.matrix(s), as.matrix(s * x)) [1] TRUE > identical(x / as.matrix(s), as.matrix(x / s)) [1] TRUE > > ### > slam/tests/stm_rollup.Rout.save0000644000175100001440000000454611515512255016411 0ustar hornikusers R version 2.12.1 Patched (2011-01-04 r53915) Copyright (C) 2011 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: i486-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("slam") > set.seed(201008) > > ## test > x <- matrix(sample(c(0,1), 100L, TRUE, prob = c(.9,.1)), 5L) > dim(x) [1] 5 20 > INDEX <- sample(1:4, 20L, TRUE) > > s <- as.simple_triplet_matrix(x) > z <- as.matrix(s) > > rollup(z, 2L, rep(1L, 20L), fivenum) 1 [1,] Numeric,5 [2,] Numeric,5 [3,] Numeric,5 [4,] Numeric,5 [5,] Numeric,5 > > identical(rollup(z, 2L, INDEX), + as.matrix(rollup(s, 2L, INDEX))) [1] TRUE > identical(rollup(t(z), 1L, INDEX), + as.matrix(rollup(t(s), 1L, INDEX))) [1] TRUE > > ## NA indexes > k <- INDEX > is.na(k) <- k == 1L > any(is.na(k)) [1] TRUE > identical(as.matrix(rollup(s, 2L, k)), + rollup(z, 2L, k)) [1] TRUE Warning message: NA(s) in 'index' > > ## other data types > s$v <- as.integer(s$v) > > identical(rollup(z, 2L, INDEX), + as.matrix(rollup(s, 2L, INDEX))) [1] TRUE > > ## NA values > is.na(s$v) <- 1:2 > z <- as.matrix(s) > z[] <- as.double(z) # coerce > > identical(rollup(z, 2L, INDEX), + as.matrix(rollup(s, 2L, INDEX))) [1] TRUE > identical(rollup(z, 2L, INDEX, na.rm = TRUE), + as.matrix(rollup(s, 2L, INDEX, na.rm = TRUE))) [1] TRUE > > ## > s$v <- as.double(s$v) > > identical(rollup(z, 2L, INDEX, na.rm = TRUE), + as.matrix(rollup(s, 2L, INDEX, na.rm = TRUE))) [1] TRUE > > > ## > s <- as.simple_sparse_array(s) > z <- as.array(z) > > identical(rollup(z, 2L, INDEX, na.rm = TRUE), + as.array(rollup(s, 2L, INDEX, na.rm = TRUE))) [1] TRUE > > ## > INDEX <- rep(1, dim(x)[2L]) > > identical(rollup(z, 2L, INDEX, na.rm = TRUE), + as.array(rollup(s, 2L, INDEX, na.rm = TRUE))) [1] TRUE > > s <- as.simple_triplet_matrix(s) > identical(rollup(z, 2L, INDEX, na.rm = TRUE), + as.array(rollup(s, 2L, INDEX, na.rm = TRUE))) [1] TRUE > ### > slam/tests/stm_apply.R0000644000175100001440000000110012262760225014515 0ustar hornikusers ## require("slam") ## x <- matrix(c(1L, 0L, 3L, 0L, 5L, 0L), ncol = 2, dimnames = list(1:3, LETTERS[1:2])) x s <- as.simple_triplet_matrix(x) colapply_simple_triplet_matrix(s, identity) rowapply_simple_triplet_matrix(s, identity) s$v <- as.numeric(s$v) simplify2array(colapply_simple_triplet_matrix(s, identity)) s$v <- as.complex(s$v) simplify2array(colapply_simple_triplet_matrix(s, identity)) s$v <- as.list(s$v) simplify2array(colapply_simple_triplet_matrix(s, identity)) s$v <- as.character(s$v) simplify2array(colapply_simple_triplet_matrix(s, identity)) ## slam/tests/stm_zeros.R0000644000175100001440000000345111320333436014537 0ustar hornikusers library("slam") set.seed(20091012) ### as.simple_triplet_matrix_zeros <- function(x) { x <- list( i = rep(seq_len(nrow(x)), ncol(x)), j = rep(seq_len(ncol(x)), each = nrow(x)), v = c(x), nrow = nrow(x), ncol = ncol(x), dimnames = dimnames(x) ) class(x) <- "simple_triplet_matrix" x } x <- sample(0:5, 100, T, prob=c(.8,rep(.04,5))) x <- matrix(as.logical(x), nrow = 20, dimnames = list(rows = 1:20, cols = LETTERS[1:5])) x xst <- as.simple_triplet_matrix_zeros(x) xst identical(rowSums(x), row_sums(xst)) identical(colSums(x), col_sums(xst)) identical(rowMeans(x), row_means(xst)) identical(colMeans(x), col_means(xst)) ## NAs xna <- x n <- prod(dim(x)) is.na(xna) <- sample(seq_len(n), ceiling(n * .1)) xna xnast <- as.simple_triplet_matrix_zeros(xna) xnast identical(rowSums(xna), row_sums(xnast)) identical(colSums(xna), col_sums(xnast)) identical(rowMeans(xna), row_means(xnast)) identical(colMeans(xna), col_means(xnast)) identical(rowSums(xna, na.rm = TRUE), row_sums(xnast, na.rm = TRUE)) identical(colSums(xna, na.rm = TRUE), col_sums(xnast, na.rm = TRUE)) identical(rowMeans(xna, na.rm = TRUE), row_means(xnast, na.rm = TRUE)) identical(colMeans(xna, na.rm = TRUE), col_means(xnast, na.rm = TRUE)) ## cross-product identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(xst)) identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(xst, x)) x <- matrix(c(1, 0, 0, 2, 1, NA), nrow = 3) x s <- as.simple_triplet_matrix_zeros(x) identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(s)) identical(tcrossprod(x), tcrossprod_simple_triplet_matrix(s, x)) ## identical(as.matrix(s * x), x * x) identical(as.matrix(x * s), x * x) identical(as.matrix(s * s), x * x) identical(as.matrix(s + s), x + x) ### slam/tests/rollup.R0000644000175100001440000000237611746150514014042 0ustar hornikusers ## library("slam") ## x <- matrix(c(1, 0, 0, 2, 1, NA), nrow = 2, dimnames = list(A = 1:2, B = 1:3)) x a <- as.simple_sparse_array(x) a ## z <- rollup(x, 2L, c(1,2,1), na.rm = TRUE) z identical(as.array(z), as.array(rollup(a, 2L, c(1,2,1), na.rm = TRUE))) identical(as.array(z), as.array(rollup(a, 2L, c(1,2,1), na.rm = TRUE, EXPAND = "dense"))) identical(as.array(z), as.array(rollup(a, 2L, c(1,2,1), na.rm = TRUE, EXPAND = "all"))) ## z <- rollup(x, 2L, c(1,NA,1), na.rm = TRUE) z identical(as.array(z), as.array(rollup(a, 2L, c(1,NA,1), na.rm = TRUE))) identical(as.array(z), as.array(rollup(a, 2L, c(1,NA,1), na.rm = TRUE, EXPAND = "dense"))) identical(as.array(z), as.array(rollup(a, 2L, c(1,NA,1), na.rm = TRUE, EXPAND = "all"))) ## z <- rollup(x, 2L, c(1,NA,1), na.rm = TRUE, DROP = TRUE) identical(as.array(z), as.array(rollup(a, 2L, c(1,NA,1), na.rm = TRUE, DROP = TRUE))) ## z <- rollup(x, 1:2, list(1:2, c(1,2,1)), na.rm = TRUE) identical(as.array(z), as.array(rollup(a, 1:2, list(1:2, c(1,2,1)), na.rm = TRUE))) ## s <- as.simple_triplet_matrix(a) z <- rollup(x, 2L, FUN = min, na.rm = TRUE) identical(as.matrix(z), as.matrix(rollup(s, 2L, FUN = min, na.rm = TRUE, EXPAND = "dense"))) ### slam/tests/matrix.R0000644000175100001440000000142211312355131014007 0ustar hornikusers library("slam") s <- simple_triplet_diag_matrix(1, nrow = 3) identical(as.matrix(s) * Inf, as.matrix(s * Inf)) identical(as.matrix(s) * NA, as.matrix(s * NA_real_)) identical(as.matrix(s) * c(Inf, NA, 0), as.matrix(s * c(Inf, NA, 0))) x1 <- matrix(c(1, Inf, 0, 1), nrow = 2) x2 <- matrix(c(1, 0, NA, 1), nrow = 2) identical(x1 * x2, as.matrix(as.simple_triplet_matrix(x1) * x2)) identical(x1 * x2, as.matrix(as.simple_triplet_matrix(x1) * as.simple_triplet_matrix(x2))) x <- matrix(1, nrow = 3, ncol = 3) identical(x * as.matrix(s), as.matrix(s * as.simple_triplet_matrix(x))) identical(x / as.matrix(s), as.matrix(as.simple_triplet_matrix(x) / s)) identical(x * as.matrix(s), as.matrix(s * x)) identical(x / as.matrix(s), as.matrix(x / s)) ### slam/src/0000755000175100001440000000000012272243253012015 5ustar hornikusersslam/src/Makevars0000644000175100001440000000004111321423036013475 0ustar hornikusersPKG_LIBS = $(BLAS_LIBS) $(FLIBS) slam/src/util.c0000644000175100001440000002045212316576356013155 0ustar hornikusers#include #include #include #include // ceeboo 2012/3+4 2013/10 // SEXP _part_index(SEXP x) { if (!inherits(x, "factor")) error("'x' not a factor"); int k; SEXP r, t; k = LENGTH(getAttrib(x, R_LevelsSymbol)); r = PROTECT(allocVector(INTSXP, LENGTH(x))); setAttrib(r, install("table"), (t = allocVector(INTSXP, k))); memset(INTEGER(t), 0, sizeof(int) * k); for (int i = 0; i < LENGTH(x); i++) { k = INTEGER(x)[i]; if (k == NA_INTEGER) INTEGER(r)[i] = k; else { k--; INTEGER(t)[k]++; INTEGER(r)[i] = INTEGER(t)[k]; } } UNPROTECT(1); return r; } SEXP _vector_index(SEXP d, SEXP x) { if (TYPEOF(d) != INTSXP || TYPEOF(x) != INTSXP) error("'d, x' not integer"); int n, m; SEXP r, dd; if (!isMatrix(x)) error("'x' not a matrix"); r = getAttrib(x, R_DimSymbol); n = INTEGER(r)[0]; m = INTEGER(r)[1]; if (m != LENGTH(d)) error("'x' and 'd' do not conform"); r = PROTECT(allocVector(INTSXP, n)); if (m > 2) { dd = PROTECT(duplicate(d)); for (int i = 1; i < m; i++) { double z = INTEGER(dd)[i] * (double) INTEGER(dd)[i-1]; if (z < INT_MAX) INTEGER(dd)[i] = (int) z; else error("'d' too large for integer"); } } else dd = d; for (int i = 0; i < n; i++) { int k = i; int l = INTEGER(x)[i]; if (l != NA_INTEGER) { if (l < 1 || l > INTEGER(d)[0]) error("'x' invalid"); for (int j = 1; j < m; j++) { k += n; int ll = INTEGER(x)[k]; if (ll == NA_INTEGER) { l = ll; break; } if (ll < 1 || ll > INTEGER(d)[j]) error("'x' invalid"); l += INTEGER(dd)[j - 1] * (ll - 1); } } INTEGER(r)[i] = l; } UNPROTECT(1 + (m > 2)); return r; } SEXP _ini_array(SEXP d, SEXP p, SEXP v, SEXP s) { if (TYPEOF(d) != INTSXP || TYPEOF(p) != INTSXP || TYPEOF(s) != INTSXP) error("'d, p, s' not integer"); int n, m; SEXP r, dd; if (!isVector(v)) error("'v' not a vector"); if (isMatrix(p)) { r = getAttrib(p, R_DimSymbol); n = INTEGER(r)[0]; if (n != LENGTH(v)) error("'p' and 'v' do not conform"); m = INTEGER(r)[1]; if (m != LENGTH(d)) error("'p' and 'd' do not conform"); r = PROTECT(allocArray(TYPEOF(v), d)); } else { n = LENGTH(p); if (n != LENGTH(v)) error("'p' and 'v' do not conform"); m = 1; if (m != LENGTH(d)) error("'p' and 'd' do not conform"); r = PROTECT(allocVector(TYPEOF(v), INTEGER(d)[0])); } switch(TYPEOF(v)) { case LGLSXP: case INTSXP: memset(INTEGER(r), 0, sizeof(int) * LENGTH(r)); break; case REALSXP: memset(REAL(r), 0, sizeof(double) * LENGTH(r)); break; case RAWSXP: memset(RAW(r), 0, sizeof(char) * LENGTH(r)); break; case CPLXSXP: memset(COMPLEX(r), 0, sizeof(Rcomplex) * LENGTH(r)); break; case EXPRSXP: case VECSXP: for (int i = 0; i < LENGTH(r); i++) SET_VECTOR_ELT(r, i, R_NilValue); break; case STRSXP: for (int i = 0; i < LENGTH(r); i++) SET_STRING_ELT(r, i, R_BlankString); break; default: error("type of 'v' not supported"); } if (m > 2) { dd = PROTECT(duplicate(d)); for (int i = 1; i < m - 1; i++) INTEGER(dd)[i] *= INTEGER(dd)[i-1]; } else dd = d; for (int i = 0; i < LENGTH(s); i++) { int k = INTEGER(s)[i]; if (k < 1 || k > n) error("'s' invalid"); k--; int h = k; int l = INTEGER(p)[k]; if (l < 1 || l > INTEGER(d)[0]) error("'p' invalid"); l--; for (int j = 1; j < m; j++) { k += n; int ll = INTEGER(p)[k]; if (ll < 1 || ll > INTEGER(d)[j]) error("'p' invalid"); ll--; l += INTEGER(dd)[j - 1] * ll; } switch(TYPEOF(v)) { case LGLSXP: case INTSXP: INTEGER(r)[l] = INTEGER(v)[h]; break; case REALSXP: REAL(r)[l] = REAL(v)[h]; break; case RAWSXP: RAW(r)[l] = RAW(v)[h]; break; case CPLXSXP: COMPLEX(r)[l] = COMPLEX(v)[h]; break; case EXPRSXP: case VECSXP: SET_VECTOR_ELT(r, l, VECTOR_ELT(v, h)); break; case STRSXP: SET_STRING_ELT(r, l, STRING_ELT(v, h)); break; default: error("type of 'v' not supported"); } } UNPROTECT(1 + (m > 2)); return r; } SEXP _split_col(SEXP x) { if (TYPEOF(x) != INTSXP) error("'x' not integer"); int n, m; SEXP r; if (!isMatrix(x)) error("'x' not a matrix"); r = getAttrib(x, R_DimSymbol); n = INTEGER(r)[0]; m = INTEGER(r)[1]; r = PROTECT(allocVector(VECSXP, m)); int k = 0; for (int i = 0; i < m; i++) { SEXP s; SET_VECTOR_ELT(r, i, (s = allocVector(INTSXP, n))); for (int j = 0; j < n; j++, k++) INTEGER(s)[j] = INTEGER(x)[k]; } UNPROTECT(1); return r; } SEXP _all_row(SEXP x, SEXP _na_rm) { if (TYPEOF(x) != LGLSXP) error("'x' not logical"); if (!isMatrix(x)) error("'x' not a matrix"); int n, m; SEXP r; r = getAttrib(x, R_DimSymbol); n = INTEGER(r)[0]; m = INTEGER(r)[1]; int na_rm; if (TYPEOF(_na_rm) != LGLSXP) error("'na_rm' not logical"); if (!LENGTH(_na_rm)) error("'na_rm' invalid length"); na_rm = LOGICAL(_na_rm)[0] == TRUE; r = PROTECT(allocVector(LGLSXP, n)); for (int i = 0; i < n; i++) { int k = i; Rboolean l = TRUE; for (int j = 0; j < m; j++, k += n) { Rboolean ll = LOGICAL(x)[k]; if (ll == NA_LOGICAL) { if (na_rm) continue; else { l = ll; break; } } if (ll == FALSE) { l = ll; if (na_rm) break; } } LOGICAL(r)[i] = l; } UNPROTECT(1); return r; } // See src/main/unique.c in the R source code. // Compare integer. static int _ieq(int *x, int *y, int i, int j, int l) { while (l-- > 0) { if (*x != *y) return 0; x += i; y += j; } return 1; } // Hash function for integer. static int _ihash(int *x, int i, int l, int k) { unsigned int j = l * 100; k = 32 - k; while (l-- > 0) { j ^= 3141592653U * (unsigned int) *x >> k; j *= 97; x += i; } return 3141592653U * j >> k; } // Add index to hash table for integer. static int _ihadd(int *x, int nr, int nc, int i, int *t, int nt, SEXP h, int k) { int *s, j; s = x + i; k = _ihash(s, nr, nc, k); while ((j = INTEGER(h)[k]) > -1) { if (_ieq(t + j, s, nt, nr, nc)) return j; k = (k + 1) % LENGTH(h); } if (t == x) INTEGER(h)[k] = i; return -1; } SEXP _match_matrix(SEXP x, SEXP y, SEXP _nm) { if (TYPEOF(x) != INTSXP) error("'x' not integer"); int nr, nc; SEXP r; if (!isMatrix(x)) error("'x' not a matrix"); r = getAttrib(x, R_DimSymbol); nr = INTEGER(r)[0]; nc = INTEGER(r)[1]; int ny = 0, nm = NA_INTEGER; if (!isNull(y)) { if (TYPEOF(y) != INTSXP) error("'y' not integer"); if (!isMatrix(y)) error("'y' not a matrix"); r = getAttrib(y, R_DimSymbol); ny = INTEGER(r)[0]; if (nc != INTEGER(r)[1]) error("'x, y' number of columns don't match"); if (!isNull(_nm)) { if (TYPEOF(_nm) != INTSXP) error("'nm' not integer"); if (LENGTH(_nm)) nm = INTEGER(_nm)[0]; } } // Initialize hash table. int hk, k, n; SEXP ht; if (nr > 1073741824) error("size %d too large for hashing", nr); k = 2 * nr; n = 2; hk = 1; while (k > n) { n *= 2; hk += 1; } ht = PROTECT(allocVector(INTSXP, n)); for (k = 0; k < n; k++) INTEGER(ht)[k] = -1; // Match. SEXP s; r = PROTECT(allocVector(VECSXP, 2)); SET_VECTOR_ELT(r, 0, (s = allocVector(INTSXP, nr))); n = 0; for (k = 0; k < nr; k++) { int j = _ihadd(INTEGER(x), nr, nc, k, INTEGER(x), nr, ht, hk); if (j > -1) INTEGER(s)[k] = INTEGER(s)[j]; else { n++; INTEGER(s)[k] = n; } } if (ny) { SEXP t; SET_VECTOR_ELT(r, 1, (t = allocVector(INTSXP, ny))); for (k = 0; k < ny; k++) { int j = _ihadd(INTEGER(y), ny, nc, k, INTEGER(x), nr, ht, hk); if (j > -1) INTEGER(t)[k] = INTEGER(s)[j]; else INTEGER(t)[k] = nm; } UNPROTECT(2); return r; } // Unique. UNPROTECT_PTR(ht); SEXP t; SET_VECTOR_ELT(r, 1, (t = allocVector(INTSXP, n))); n = 1; for (k = 0; k < nr; k++) if (INTEGER(s)[k] == n) { INTEGER(t)[n - 1] = k + 1; n++; } UNPROTECT(1); return r; } // Use with care! SEXP _stripDimNamesNames(SEXP x) { SEXP d = getAttrib(x, R_DimNamesSymbol); if (!isNull(d)) setAttrib(d, R_NamesSymbol, R_NilValue); return x; } slam/src/apply.c0000644000175100001440000000776212316576356013336 0ustar hornikusers #include #include #include extern int _valid_stm(SEXP x); // (C) ceeboo 2013/12 // // Wrapper for simple triplet matrix which runs in constant // memory. SEXP _col_apply_stm(SEXP a) { a = CDR(a); if (length(a) < 2) error("invalid number of arguments"); SEXP x = CAR(a); if (!inherits(x, "simple_triplet_matrix") || _valid_stm(x)) error("'x' not of class 'simple_triplet_matrix'"); if (!isFunction(CADR(a))) error("invalid function parameter"); int n, m, *_ix, *_jx, *_nx, *_px; SEXP vx, z, r; vx = VECTOR_ELT(x, 2); n = INTEGER(VECTOR_ELT(x, 3))[0]; m = INTEGER(VECTOR_ELT(x, 4))[0]; z = PROTECT(allocVector(TYPEOF(vx), n)); a = PROTECT(LCONS(CADR(a), LCONS(z, CDDR(a)))); switch(TYPEOF(vx)) { case LGLSXP: case INTSXP: memset(INTEGER(z), 0, sizeof(int) * n); break; case REALSXP: memset(REAL(z), 0, sizeof(double) * n); break; case RAWSXP: memset(RAW(z), 0, sizeof(char) * n); break; case CPLXSXP: memset(COMPLEX(z), 0, sizeof(Rcomplex) * n); break; case EXPRSXP: case VECSXP: for (int i = 0; i < n; i++) SET_VECTOR_ELT(z, i, R_NilValue); break; case STRSXP: for (int i = 0; i < n; i++) SET_STRING_ELT(z, i, R_BlankString); break; default: error("type of 'v' not supported"); } // Map blocks of equal column indexes _jx = INTEGER(VECTOR_ELT(x, 1)); // column indexes _nx = INTEGER(PROTECT(allocVector(INTSXP, m + 1))); memset(_nx, 0, sizeof(int) * (m + 1)); for (int k = 0; k < LENGTH(vx); k++) _nx[_jx[k]]++; for (int k = 1; k < m + 1; k++) _nx[k] += _nx[k-1]; _px = INTEGER(PROTECT(allocVector(INTSXP, LENGTH(vx)))); _nx -= 1; // one-based R indexing for (int k = 0; k < LENGTH(vx); k++) { _px[_nx[_jx[k]]] = k; _nx[_jx[k]]++; } // Reset _nx += 1; for (int k = m; k > 0; k--) _nx[k] = _nx[k-1]; _nx[0] = 0; _ix = INTEGER(VECTOR_ELT(x, 0)); // row indexes r = PROTECT(allocVector(VECSXP, m)); int f, fl; f = fl = _nx[0]; for (int i = 1; i < m + 1; i++) { int l = _nx[i]; // (Re)set values switch(TYPEOF(vx)) { case LGLSXP: case INTSXP: for (int k = fl; k < f; k++) INTEGER(z)[_px[k]] = 0; for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; INTEGER(z)[i] = INTEGER(vx)[p]; _px[k] = i; } break; case REALSXP: for (int k = fl; k < f; k++) REAL(z)[_px[k]] = 0.0; for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; REAL(z)[i] = REAL(vx)[p]; _px[k] = i; } break; case RAWSXP: for (int k = fl; k < f; k++) RAW(z)[_px[k]] = (char) 0; for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; RAW(z)[i] = RAW(vx)[p]; _px[k] = i; } break; case CPLXSXP: for (int k = fl; k < f; k++) { static Rcomplex c; COMPLEX(z)[_px[k]] = c; } for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; COMPLEX(z)[i] = COMPLEX(vx)[p]; _px[k] = i; } break; case EXPRSXP: case VECSXP: for (int k = fl; k < f; k++) SET_VECTOR_ELT(z, _px[k], R_NilValue); for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; SET_VECTOR_ELT(z, i, VECTOR_ELT(vx, p)); _px[k] = i; } break; case STRSXP: for (int k = fl; k < f; k++) SET_STRING_ELT(z, _px[k], R_BlankString); for (int k = f; k < l; k++) { int p = _px[k], i = _ix[p] - 1; SET_STRING_ELT(z, i, STRING_ELT(vx, p)); _px[k] = i; } break; default: error("type of 'v' not supported"); } SEXP s = eval(a, R_GlobalEnv); if (s == z) // identity, print, ... SET_VECTOR_ELT(r, i - 1, duplicate(s)); else SET_VECTOR_ELT(r, i - 1, s); fl = f; f = l; } UNPROTECT(5); return r; } slam/src/grouped.c0000644000175100001440000001041712316576356013645 0ustar hornikusers#include #include #include extern int _valid_stm(SEXP x); // ceeboo 2010/8+10 // // sum (collapse) the rows of x into the column groups // defined in index. // SEXP _row_tsums(SEXP x, SEXP R_index, SEXP R_na_rm, SEXP R_verbose) { if (!inherits(x, "simple_triplet_matrix") || _valid_stm(x)) error("'x' not of class 'simple_triplet_matrix'"); if (!inherits(R_index, "factor")) error("'index' not of class 'factor'"); int *p, *q, k, n, m, f, l; SEXP _v, _i, _j, __i, __v, r, s; if (LENGTH(R_index) != INTEGER(VECTOR_ELT(x, 4))[0]) error("'index' invalid length"); #ifdef _TIME_H // code section times clock_t t2, t1, t0 = clock(); #endif _i = VECTOR_ELT(x, 0); p = INTEGER(PROTECT(allocVector(INTSXP, LENGTH(_i)))); q = INTEGER(PROTECT(allocVector(INTSXP, LENGTH(_i)))); // sort by row indexes for (int i = 0; i < LENGTH(_i); i++) { p[i] = INTEGER(_i)[i]; q[i] = i; } if (LENGTH(_i)) R_qsort_int_I(p, q, 1, LENGTH(_i)); // sort row blocks by column indexes // // NOTE we change the sign with each block // to ensure a change in key. // _j = VECTOR_ELT(x, 1); f = 0; l = 0; n = 0; m = 0; for (int i = 0; i < LENGTH(_i); i++) { k = INTEGER(R_index)[INTEGER(_j)[q[i]] - 1]; if (k == NA_INTEGER) continue; if (n != p[i]) { n = p[i]; if (f < l) R_qsort_int_I(p, q, f, l); f = l + 1; m = (m) ? 0 : 1; } p[l] = (m) ? k : -k; q[l] = q[i]; l++; } if (l) { R_qsort_int_I(p, q, f, l); // FIXME this may be time-consuming. if (l < LENGTH(_i)) warning("NA(s) in 'index'"); else for (int i = 0; i < LENGTH(R_index); i++) if (INTEGER(R_index)[i] == NA_INTEGER) { warning("NA(s) in 'index'"); break; } } // count n = 0; k = 0; for (int i = 0; i < l; i++) if (k != p[i]) { k = p[i]; n++; } // NOTE use REALSXP to avoid overflows. r = PROTECT(allocVector(VECSXP, 6)); SET_VECTOR_ELT(r, 0, (__i = allocVector(INTSXP, n))); SET_VECTOR_ELT(r, 1, ( _j = allocVector(INTSXP, n))); SET_VECTOR_ELT(r, 2, (__v = allocVector(REALSXP, n))); SET_VECTOR_ELT(r, 3, VECTOR_ELT(x, 3)); SET_VECTOR_ELT(r, 4, ScalarInteger(LENGTH(getAttrib(R_index, R_LevelsSymbol)))); SET_VECTOR_ELT(r, 5, (s = allocVector(VECSXP, 2))); SET_VECTOR_ELT(s, 0, R_NilValue); SET_VECTOR_ELT(s, 1, getAttrib(R_index, R_LevelsSymbol)); if (LENGTH(x) > 5) { SEXP t = VECTOR_ELT(x, 5); if (!isNull(t)) { SET_VECTOR_ELT(s, 0, VECTOR_ELT(t, 0)); if (!isNull((t = getAttrib(t, R_NamesSymbol)))) setAttrib(s, R_NamesSymbol, t); } setAttrib(r, R_NamesSymbol, getAttrib(x, R_NamesSymbol)); } else { setAttrib(r, R_NamesSymbol, (s = allocVector(STRSXP, 6))); SEXP t = getAttrib(x, R_NamesSymbol); for (int i = 0; i < 5; i++) SET_STRING_ELT(s, i, STRING_ELT(t, i)); SET_STRING_ELT(s, 5, mkString("dimnames")); } setAttrib(r, R_ClassSymbol, getAttrib(x, R_ClassSymbol)); #ifdef _TIME_H t1 = clock(); #endif double *_z = REAL(__v); _v = VECTOR_ELT(x, 2); n = 0; k = 0; switch (TYPEOF(_v)) { case LGLSXP: case INTSXP: for (int i = 0; i < l; i++) { if (k != p[i]) { k = p[i]; INTEGER(__i)[n] = INTEGER(_i)[q[i]]; INTEGER( _j)[n] = (k > 0) ? k : -k; _z = REAL(__v) + n; *_z = 0; n++; } int z = INTEGER(_v)[q[i]]; if (z != NA_INTEGER) *_z += (double) z; else if (!LOGICAL(R_na_rm)[0]) *_z += NA_REAL; } break; case REALSXP: for (int i = 0; i < l; i++) { if (k != p[i]) { k = p[i]; INTEGER(__i)[n] = INTEGER(_i)[q[i]]; INTEGER( _j)[n] = (k > 0) ? k : -k; _z = REAL(__v) + n; *_z = 0; n++; } double z = REAL(_v)[q[i]]; // NOTE with na.rm == TRUE the sum may be zero if (!ISNAN(z) || !LOGICAL(R_na_rm)[0]) *_z += z; } break; default: error("type of 'v' not supported"); } #ifdef _TIME_H t2 = clock(); if (R_verbose && *LOGICAL(R_verbose)) Rprintf("_row_tsums: %.3fs [%.3fs/%.3fs]\n", ((double) t2 - t0) / CLOCKS_PER_SEC, ((double) t1 - t0) / CLOCKS_PER_SEC, ((double) t2 - t1) / CLOCKS_PER_SEC); #endif UNPROTECT(3); return r; } slam/src/sparse.c0000644000175100001440000004623512316576356013504 0ustar hornikusers#include #include #include #include #include // ceeboo 2009/5,10,12 2010/1,5,6 2011/2 2012/4,5 2013/10 // // remove attributes from payload vector (see src/main/coerce.c) SEXP _unattr(SEXP x) { if (!isVector(x) || ATTRIB(x) == R_NilValue) return x; if (NAMED(x) > 1) { SEXP s = x; SEXP a = PROTECT(ATTRIB(x)); SET_ATTRIB(x, R_NilValue); x = duplicate(x); SET_ATTRIB(s, a); UNPROTECT_PTR(a); } else SET_ATTRIB(x, R_NilValue); if (OBJECT(x)) SET_OBJECT(x, 0); if (IS_S4_OBJECT(x)) UNSET_S4_OBJECT(x); return x; } // test validity of payload vector int _valid_v(SEXP x) { if (!isVector(x)) error("'x' not a vector"); int i; i = LENGTH(x); switch(TYPEOF(x)) { case LGLSXP: // test for FALSE (see below) case INTSXP: { int *v = INTEGER(x); while (i-- > 0) if (v[i] == 0) break; } break; case REALSXP: { double *v = REAL(x); while (i-- > 0) if (v[i] == (double) 0) break; } break; case RAWSXP: { unsigned char *v = RAW(x); while (i-- > 0) if (v[i] == (unsigned char) 0) break; } break; case CPLXSXP: { Rcomplex *v = COMPLEX(x); while (i-- > 0) if (v[i].i == (double) 0 || v[i].r == (double) 0) break; } break; case EXPRSXP: case VECSXP: while (i-- > 0) if (VECTOR_ELT(x, i) == R_NilValue) break; break; case STRSXP: while (i-- > 0) if (STRING_ELT(x, i) == R_BlankString) break; break; default: error("type not implemented"); } return i + 1; } // wrapper SEXP __valid_v(SEXP x) { return ScalarLogical(_valid_v(x) == FALSE); } // test validity of list components. int _valid_stm(SEXP x) { if (LENGTH(x) < 5) error("invalid number of components"); SEXP s = getAttrib(x, R_NamesSymbol); int ok = strcmp(CHAR(STRING_ELT(s, 0)), "i") || strcmp(CHAR(STRING_ELT(s, 1)), "j") || strcmp(CHAR(STRING_ELT(s, 2)), "v") || strcmp(CHAR(STRING_ELT(s, 3)), "nrow") || strcmp(CHAR(STRING_ELT(s, 4)), "ncol") || ((LENGTH(s) > 5) ? strcmp(CHAR(STRING_ELT(s, 5)), "dimnames") : 0); if (!ok) { if (TYPEOF(VECTOR_ELT(x, 0)) != INTSXP || TYPEOF(VECTOR_ELT(x, 1)) != INTSXP || TYPEOF(VECTOR_ELT(x, 3)) != INTSXP || TYPEOF(VECTOR_ELT(x, 4)) != INTSXP) error("'i, j, nrow, ncol' invalid type"); if (!isVector(VECTOR_ELT(x, 2))) error("'v' not a vector"); s = VECTOR_ELT(x, 0); if (LENGTH(s) != LENGTH(VECTOR_ELT(x, 1)) || LENGTH(s) != LENGTH(VECTOR_ELT(x, 2))) error("'i, j, v' different lengths"); if (LENGTH(VECTOR_ELT(x, 3)) != 1 || LENGTH(VECTOR_ELT(x, 4)) != 1) error("'nrow, ncol' invalid length"); int *xi, *xj, nr, nc; xi = INTEGER(s); xj = INTEGER(VECTOR_ELT(x, 1)); nr = INTEGER(VECTOR_ELT(x, 3))[0]; nc = INTEGER(VECTOR_ELT(x, 4))[0]; if (nr < 0 || nr == NA_INTEGER || nc < 0 || nc == NA_INTEGER) error("'nrow, ncol' invalid"); for (int k = 0; k < LENGTH(s); k++) if (xi[k] < 1 || xi[k] > nr || xj[k] < 1 || xj[k] > nc) error("'i, j' invalid"); if (LENGTH(x) > 5) { s = VECTOR_ELT(x, 5); if (!isNull(s)) { if (TYPEOF(s) != VECSXP) error("'dimnames' invalid type"); if (LENGTH(s) != 2) error("'dimnames' invalid length"); if ((!isNull(VECTOR_ELT(s, 0)) && (LENGTH(VECTOR_ELT(s, 0)) != nr || !isString(VECTOR_ELT(s, 0)))) || (!isNull(VECTOR_ELT(s, 1)) && (LENGTH(VECTOR_ELT(s, 1)) != nc || !isString(VECTOR_ELT(s, 1))))) error("'dimnames' component invalid length or type"); } } } return ok; } // wrapper SEXP __valid_stm(SEXP x) { if (!inherits(x, "simple_triplet_matrix")) return ScalarLogical(FALSE); return ScalarLogical(_valid_stm(x) == FALSE); } // row or column sums of some triplet matrix // SEXP _sums_stm(SEXP x, SEXP R_dim, SEXP R_na_rm) { if (!inherits(x, "simple_triplet_matrix") || _valid_stm(x)) error("'x' not of class 'simple_triplet_matrix'"); if (TYPEOF(R_dim) != INTSXP) error("'dim' not of type integer"); if (TYPEOF(R_na_rm) != LGLSXP) error("'na.rm' not of type logical"); int n, *i = NULL; switch ((n = *INTEGER(R_dim))) { case 1: i = INTEGER(VECTOR_ELT(x, 0)); break; case 2: i = INTEGER(VECTOR_ELT(x, 1)); break; default: error("'dim' invalid"); } n = INTEGER(VECTOR_ELT(x, n + 2))[0]; // for the type of the return argument see the behavior // of rowSums and colSums for matrix. SEXP r = PROTECT(allocVector(REALSXP, n)); memset(REAL(r), 0, sizeof(double) * n); // offset one-based indexing double *__r__ = REAL(r) - 1; SEXP _x_ = VECTOR_ELT(x, 2); switch (TYPEOF(_x_)) { case LGLSXP: case INTSXP: { int v, *k, *__x__ = INTEGER(_x_); if (*LOGICAL(R_na_rm)) { for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) if ((v = *__x__) == NA_INTEGER) continue; else __r__[*i] += (double) v; } else { for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) __r__[*i] += // map NA ((v = *__x__) == NA_INTEGER) ? NA_REAL : v; } break; } case REALSXP: { double v, *k, *__x__ = REAL(_x_); if (*LOGICAL(R_na_rm)) { for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) if (ISNAN((v = *__x__))) continue; else __r__[*i] += v; } else for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) __r__[*i] += *__x__; break; } default: error("type of 'x' not supported"); } SEXP d = (LENGTH(x) > 5) ? VECTOR_ELT(x, 5) : R_NilValue; if (!isNull(d)) { n = *INTEGER(R_dim); setAttrib(r, R_NamesSymbol, VECTOR_ELT(d, n - 1)); } UNPROTECT(1); return r; } // tcrossprod for some triplet matrices. // // NOTES 1) y is now implemented. // 2) pkgEnv = NULL deactivates the bailout to dense // computation. // SEXP tcrossprod_stm_stm(SEXP x, SEXP y, SEXP pkgEnv, SEXP R_verbose) { if (!inherits(x, "simple_triplet_matrix") || _valid_stm(x)) error("'x' not of class simple_triplet_matrix"); if (!isNull(y) && (!inherits(y, "simple_triplet_matrix") || _valid_stm(y))) error("'y' not of class simple_triplet_matrix"); int *_ix, *_jx, *_nx, k, fx, l, n, m; double *_vx, *_vy = NULL, *_r; SEXP r, vx, vy = NULL; l = INTEGER(VECTOR_ELT(x, 4))[0]; if (!isNull(y) && l != INTEGER(VECTOR_ELT(y, 4))[0]) error("the number of columns of 'x' and 'y' do not conform"); #ifdef _TIME_H clock_t t2, t1, t0 = clock(); #endif vx = VECTOR_ELT(x, 2); if (TYPEOF(vx) != REALSXP) vx = PROTECT(coerceVector(vx, REALSXP)); _vx = REAL(vx); for (k = 0; k < LENGTH(vx); k++) if (!R_FINITE(_vx[k])) { if (isNull(pkgEnv)) error("NA/NaN handling deactivated"); if (vx != VECTOR_ELT(x, 2)) UNPROTECT(1); r = eval(PROTECT(LCONS(install(".tcrossprod_bailout"), CONS(x, CONS(y, CONS(ScalarLogical(FALSE), R_NilValue))))), pkgEnv); UNPROTECT(1); return r; } n = INTEGER(VECTOR_ELT(x, 3))[0]; if (!isNull(y)) { vy = VECTOR_ELT(y, 2); if (TYPEOF(vy) != REALSXP) vy = PROTECT(coerceVector(vy, REALSXP)); _vy = REAL(vy); for (k = 0; k < LENGTH(vy); k++) if (!R_FINITE(_vy[k])) { if (isNull(pkgEnv)) error("NA/NaN handling deactivated"); if (vy != VECTOR_ELT(y, 2)) UNPROTECT(1); if (vx != VECTOR_ELT(x, 2)) UNPROTECT(1); r = eval(PROTECT(LCONS(install(".tcrossprod_bailout"), CONS(x, CONS(y, CONS(ScalarLogical(FALSE), R_NilValue))))), pkgEnv); UNPROTECT(1); return r; } m = INTEGER(VECTOR_ELT(y, 3))[0]; } else m = n; r = PROTECT(allocMatrix(REALSXP, n, m)); memset(REAL(r), 0, sizeof(double) * n * m); { SEXP sx, dx, sy, dy; sx = dx = sy = dy = R_NilValue; if (LENGTH(x) > 5) { sx = VECTOR_ELT(x, 5); if (!isNull(sx)) { dx = VECTOR_ELT(sx, 0); sx = getAttrib(sx, R_NamesSymbol); if (!isNull(sx)) sx = STRING_ELT(sx, 0); } } if (!isNull(y)) { if (LENGTH(y) > 5) { sy = VECTOR_ELT(y, 5); if (!isNull(sy)) { dy = VECTOR_ELT(sy, 0); sy = getAttrib(sy, R_NamesSymbol); if (!isNull(sy)) sy = STRING_ELT(sy, 0); } } } else { sy = sx; dy = dx; } if (!isNull(dx) || !isNull(dy)) { SEXP d; setAttrib(r, R_DimNamesSymbol, (d = allocVector(VECSXP, 2))); SET_VECTOR_ELT(d, 0, dx); SET_VECTOR_ELT(d, 1, dy); if (!isNull(sx) || !isNull(sy)) { SEXP s; setAttrib(d, R_NamesSymbol, (s = allocVector(STRSXP, 2))); SET_STRING_ELT(s, 0, isNull(sx) ? R_BlankString : sx); SET_STRING_ELT(s, 1, isNull(sy) ? R_BlankString : sy); } } } if (!l || !n || !LENGTH(vx) || (!isNull(y) && (!m || !LENGTH(vy)))) { UNPROTECT(1); if (vx != VECTOR_ELT(x, 2)) UNPROTECT(1); if (!isNull(y) && vy != VECTOR_ELT(y, 2)) UNPROTECT(1); return r; } // Arrange the data in blocks of equal column // indexes. Note that the order within (of) // the blocks is not relevant (see below). _jx = INTEGER(VECTOR_ELT(x, 1)); // column indexes _nx = INTEGER(PROTECT(allocVector(INTSXP, l + 1))); memset(_nx, 0, sizeof(int) * (l + 1)); for (k = 0; k < LENGTH(vx); k++) _nx[_jx[k]]++; for (k = 1; k < l + 1; k++) _nx[k] += _nx[k-1]; { int *__i; double *__v; __i = INTEGER(VECTOR_ELT(x, 0)); // row indexs __v = _vx; _ix = INTEGER(PROTECT(allocVector(INTSXP, LENGTH(vx)))); _vx = REAL(PROTECT(allocVector(REALSXP, LENGTH(vx)))); _nx -= 1; for (k = 0; k < LENGTH(vx); k++) { int *__n = _nx + _jx[k]; _ix[*__n] = __i[k]; _vx[*__n] = __v[k]; (*__n)++; } // reset _nx += 1; for (k = l; k > 0; k--) _nx[k] = _nx[k-1]; _nx[0] = 0; } #ifdef _TIME_H t1 = clock(); #endif // Aggregate the outer products of the columns. if (isNull(y)) { _r = REAL(r) - n - 1; fx = _nx[0]; for (k = 1; k < l + 1; k++) { int lx = _nx[k]; for (int j = fx; j < lx; j++) { double z = _vx[j], *_z = _r + _ix[j] * n; for (int i = fx; i < j + 1; i++) _z[_ix[i]] += _vx[i] * z; } fx = lx; } // Aggregate the lower and upper half. _r = REAL(r); for (k = 1; k < n; k++) { int j = k * n; // NOTE the off-diagonal array indexes are i * n + k, // and k * n + i for i = 0, 1, ..., k-1. For the // former (k - 1) * n + k < k * n <=> k < n, // and adding k to the right sides does not // change that. for (int i = k; i < j; i += n, j++) { _r[j] += _r[i]; _r[i] = _r[j]; } } } else { int *_iy, *_jy; _r = REAL(r) - n - 1; _iy = INTEGER(VECTOR_ELT(y, 0)); _jy = INTEGER(VECTOR_ELT(y, 1)); // column indexes for (k = 0; k < LENGTH(vy); k++) { int j = _jy[k]; double z = _vy[k], *_z = _r + _iy[k] * n; for (int i = _nx[j-1]; i < _nx[j]; i++) _z[_ix[i]] += _vx[i] * z; } } #ifdef _TIME_H t2 = clock(); if (R_verbose && *LOGICAL(R_verbose)) Rprintf("tcrossprod_stm_stm: %.3fs [%.3fs/%.3fs]\n", ((double) t2 - t0) / CLOCKS_PER_SEC, ((double) t1 - t0) / CLOCKS_PER_SEC, ((double) t2 - t1) / CLOCKS_PER_SEC); #endif UNPROTECT(4); if (vx != VECTOR_ELT(x, 2)) UNPROTECT(1); if (!isNull(y) && vy != VECTOR_ELT(y, 2)) UNPROTECT(1); return r; } // tcrossprod for some triplet matrix and matrix // // NOTES 1) tcrossprod does not implement na.rm, so neither do we. // 2) triplet on triplet does not fit in here. // 3) if y contains special values we call some bailout // function. // 4) pkgEnv = NULL deactivates the bailout. // 5) transpose // SEXP tcrossprod_stm_matrix(SEXP x, SEXP R_y, SEXP pkgEnv, SEXP R_verbose, SEXP R_transpose) { if (isNull(R_y)) return tcrossprod_stm_stm(x, R_y, pkgEnv, R_verbose); if (!inherits(x, "simple_triplet_matrix") || _valid_stm(x)) error("'x' not of class simple_triplet_matrix"); if (!isMatrix(R_y)) error("'y' not of class matrix"); int n, m; SEXP y = R_y; n = INTEGER(VECTOR_ELT(x, 4))[0]; if (n != INTEGER(getAttrib(y, R_DimSymbol))[1]) error("the number of columns of 'x' and 'y' do not conform"); n = INTEGER(VECTOR_ELT(x, 3))[0]; m = INTEGER(getAttrib(y, R_DimSymbol))[0]; #ifdef _TIME_H // code section times clock_t t3, t2, t1, t0 = clock(); #endif // coercing is in general not storage efficient, and therefore // assumes that y is not too large. on the other hand, as the // entries of y could be accessed multiple times, casting would // not be runtime efficient. if memory footprint is of concern // then the program flow should be further switch(ed). if (TYPEOF(y) != REALSXP) y = PROTECT(coerceVector(y, REALSXP)); // check for special values SEXP r; double *_y = REAL(y); for (double *k = _y + LENGTH(y); _y < k; _y++) if (!R_FINITE(*_y)) { if (isNull(pkgEnv)) error("NA/NaN handling deactivated"); r = eval(PROTECT(LCONS(install(".tcrossprod_bailout"), CONS(x, CONS(y, CONS((R_transpose && *LOGICAL(R_transpose)) ? R_transpose : ScalarLogical(FALSE), R_NilValue))))), pkgEnv); UNPROTECT(1); if (y != R_y) UNPROTECT(1); return r; } _y = REAL(y) - m; r = PROTECT(allocVector(REALSXP, n * m)); memset(REAL(r), 0, sizeof(double) * n * m); double *_r = REAL(r) - m; int *_i, *_j; _i = INTEGER(VECTOR_ELT(x, 0)); _j = INTEGER(VECTOR_ELT(x, 1)); // Notes 1) timings with Blas are better than without. // 2) For reasons not yet fully understood using // a transposed result matrix is more runtime // efficient. SEXP v = VECTOR_ELT(x, 2); #ifdef _TIME_H t1 = clock(); #endif switch (TYPEOF(v)) { case LGLSXP: case INTSXP: { int *k, *__x = INTEGER(v); double *l, *__r, *__y; for (k = __x + LENGTH(v); __x < k; __x++, _i++, _j++) { __r = _r + *_i * m; __y = _y + *_j * m; for (l = __y + m; __y < l; __y++, __r++) *__r += *__x * *__y; } break; } case REALSXP: { double *k, *__x = REAL(v); #ifdef R_BLAS_H int l = 1, *_l = &l, *_m = &m; #else double *l, *__r, *__y; #endif for (k = __x + LENGTH(v); __x < k; __x++, _i++, _j++) { #ifdef R_BLAS_H F77_NAME(daxpy)(_m, __x, _y + *_j * m, _l, _r + *_i * m, _l); #else __r = _r + *_i * m; __y = _y + *_j * m; for (l = __y + m; __y < l; __y++, __r++) *__r += *__x * *__y; #endif } break; } default: error("type of 'x' not supported"); } #ifdef _TIME_H t2 = clock(); #endif // transpose if (!R_transpose || !*LOGICAL(R_transpose)) { v = r; _y = REAL(v); r = PROTECT(allocMatrix(REALSXP, n, m)); _r = REAL(r); for (int i = 0; i < n * m; i++) _r[i] = _y[i / n + (i % n) * m]; UNPROTECT_PTR(v); } else { // NOTE we rely on setAttrib to not check if the dimnames // are consistent with dim. SEXP d = PROTECT(allocVector(INTSXP, 2)); INTEGER(d)[0] = m; INTEGER(d)[1] = n; setAttrib(r, R_DimSymbol, d); UNPROTECT(1); } // set dimnames and names of dimnames. SEXP dn = (LENGTH(x) > 5) ? VECTOR_ELT(x, 5) : R_NilValue; if (!isNull(dn)) { SEXP d, dnn; dnn = getAttrib(dn, R_NamesSymbol); setAttrib(r, R_DimNamesSymbol, (d = allocVector(VECSXP, 2))); SET_VECTOR_ELT(d, 0, VECTOR_ELT(dn, 0)); dn = getAttrib(y, R_DimNamesSymbol); if (!isNull(dn)) { SET_VECTOR_ELT(d, 1, VECTOR_ELT(dn, 0)); if (!isNull(dnn)) { SEXP t; setAttrib(d, R_NamesSymbol, (t = allocVector(STRSXP, 2))); SET_STRING_ELT(t, 0, STRING_ELT(dnn, 0)); dnn = getAttrib(dn, R_NamesSymbol); if (!isNull(dnn)) SET_STRING_ELT(t, 1, STRING_ELT(dnn, 0)); else SET_STRING_ELT(t, 1, R_BlankString); } else { dnn = getAttrib(dn, R_NamesSymbol); if (!isNull(dnn)) { SEXP t; setAttrib(d, R_NamesSymbol, (t = allocVector(STRSXP, 2))); SET_STRING_ELT(t, 0, R_BlankString); SET_STRING_ELT(t, 1, STRING_ELT(dnn, 0)); } } } else { SET_VECTOR_ELT(d, 1, R_NilValue); if (!isNull(dnn)) { SEXP t; setAttrib(d, R_NamesSymbol, (t = allocVector(STRSXP, 2))); SET_STRING_ELT(t, 0, STRING_ELT(dnn, 0)); SET_STRING_ELT(t, 1, R_BlankString); } } } else { dn = getAttrib(y, R_DimNamesSymbol); if (!isNull(dn)) { SEXP d; setAttrib(r, R_DimNamesSymbol, (d = allocVector(VECSXP, 2))); SET_VECTOR_ELT(d, 0, R_NilValue); SET_VECTOR_ELT(d, 1, VECTOR_ELT(dn, 0)); dn = getAttrib(dn, R_NamesSymbol); if (!isNull(dn)) { SEXP t; setAttrib(d, R_NamesSymbol, (t = allocVector(STRSXP, 2))); SET_STRING_ELT(t, 0, R_BlankString); SET_STRING_ELT(t, 1, STRING_ELT(dn, 0)); } } } // swap dimnames if (R_transpose && *LOGICAL(R_transpose)) { dn = getAttrib(r, R_DimNamesSymbol); if (!isNull(dn)) { SEXP t; t = VECTOR_ELT(dn, 0); SET_VECTOR_ELT(dn, 0, VECTOR_ELT(dn, 1)); SET_VECTOR_ELT(dn, 1, t); dn = getAttrib(dn, R_NamesSymbol); if (!isNull(dn)) { t = STRING_ELT(dn, 0); SET_STRING_ELT(dn, 0, STRING_ELT(dn, 1)); SET_STRING_ELT(dn, 1, t); } } } #ifdef _TIME_H t3 = clock(); if (R_verbose && *LOGICAL(R_verbose)) Rprintf("tcrossprod_stm_matrix: %.3fs [%.3fs/%.3fs/%.3fs]\n", ((double) t3 - t0) / CLOCKS_PER_SEC, ((double) t1 - t0) / CLOCKS_PER_SEC, ((double) t2 - t1) / CLOCKS_PER_SEC, ((double) t3 - t2) / CLOCKS_PER_SEC); #endif UNPROTECT(1); if (y != R_y) UNPROTECT(1); return r; } // test validity of list components. int _valid_ssa(SEXP x) { if (LENGTH(x) < 3) error("invalid number of components"); SEXP s = getAttrib(x, R_NamesSymbol); int ok = strcmp(CHAR(STRING_ELT(s, 0)), "i") || strcmp(CHAR(STRING_ELT(s, 1)), "v") || strcmp(CHAR(STRING_ELT(s, 2)), "dim") || ((LENGTH(s) > 3) ? strcmp(CHAR(STRING_ELT(s, 3)), "dimnames") : 0); if (!ok) { if (TYPEOF(VECTOR_ELT(x, 0)) != INTSXP || TYPEOF(VECTOR_ELT(x, 2)) != INTSXP) error("'i, dim' invalid type"); if (!isVector(VECTOR_ELT(x, 1))) error("'v' not a vector"); int *xi, *xd, nr, nc; s = VECTOR_ELT(x, 0); if (!isMatrix(s)) error("'i' not a matrix"); xi = INTEGER(s); s = getAttrib(s, R_DimSymbol); nr = INTEGER(s)[0]; if (nr != LENGTH(VECTOR_ELT(x, 1))) error("'i, v' invalid length"); nc = INTEGER(s)[1]; s = VECTOR_ELT(x, 2); if (nc != LENGTH(s)) error("'i, dim' invalid length"); xd = INTEGER(s); for (int j = 0; j < nc; j++) { int n = xd[j]; if (n > 0) { if (n == NA_INTEGER) error("'dim' invalid"); for (int i = 0; i < nr; i++) if (xi[i] < 1 || xi[i] > n) error("i invalid"); } else if (n < 0) error("'dim' invalid"); else if (nr > 0) error("'dim, i' invalid number of rows"); xi += nr; } if (LENGTH(x) > 3) { s = VECTOR_ELT(x, 3); if (!isNull(s)) { if (TYPEOF(s) != VECSXP) error("'dimnames' invalid type"); if (LENGTH(s) != nc) error("'dimnames' invalid length"); for (int j = 0; j < nc; j++) if (!isNull(VECTOR_ELT(s, j)) && (LENGTH(VECTOR_ELT(s, j)) != xd[j] || !isString(VECTOR_ELT(s, j)))) error("'dimnames' component invalid length or type"); } } } return ok; } // wrapper SEXP __valid_ssa(SEXP x) { if (!inherits(x, "simple_sparse_array")) return ScalarLogical(FALSE); return ScalarLogical(_valid_ssa(x) == FALSE); } // slam/NAMESPACE0000644000175100001440000001146712311526577012465 0ustar hornikusersimportFrom("stats", "na.omit") ## Simple triplet matrix stuff export("as.simple_triplet_matrix", "is.simple_triplet_matrix", "simple_triplet_diag_matrix", "simple_triplet_matrix", "simple_triplet_zero_matrix" ) S3method("[", "simple_triplet_matrix") S3method("[<-", "simple_triplet_matrix") S3method("Math", "simple_triplet_matrix") S3method("Ops", "simple_triplet_matrix") S3method("Summary", "simple_triplet_matrix") S3method("as.matrix", "simple_triplet_matrix") S3method("as.simple_triplet_matrix", "simple_sparse_array") S3method("as.simple_triplet_matrix", "simple_triplet_matrix") S3method("as.simple_triplet_matrix", "matrix") S3method("as.simple_triplet_matrix", "default") S3method("as.simple_triplet_matrix", "dgTMatrix") S3method("as.simple_triplet_matrix", "dgCMatrix") S3method("as.simple_triplet_matrix", "dgRMatrix") S3method("as.simple_triplet_matrix", "matrix.coo") S3method("as.simple_triplet_matrix", "matrix.csr") S3method("as.simple_triplet_matrix", "matrix.csc") S3method("as.simple_triplet_matrix", "spam") S3method("as.vector", "simple_triplet_matrix") S3method("c", "simple_triplet_matrix") S3method("cbind", "simple_triplet_matrix") S3method("dim", "simple_triplet_matrix") S3method("dim<-", "simple_triplet_matrix") S3method("dimnames", "simple_triplet_matrix") S3method("dimnames<-", "simple_triplet_matrix") S3method("duplicated", "simple_triplet_matrix") S3method("is.numeric", "simple_triplet_matrix") S3method("mean", "simple_triplet_matrix") S3method("print", "simple_triplet_matrix") S3method("rbind", "simple_triplet_matrix") S3method("t", "simple_triplet_matrix") S3method("unique", "simple_triplet_matrix") ## enhanced stuff useDynLib("slam", "__valid_stm", "__valid_ssa", "__valid_v", "_split_col", "_all_row", "_part_index", "_vector_index", "_ini_array", "_match_matrix", "_unattr", "_sums_stm", "_row_tsums", ## used by skmeans "_tcrossprod_stm_stm" = "tcrossprod_stm_stm", "_tcrossprod_stm_matrix" = "tcrossprod_stm_matrix", "_col_apply_stm", .fixes = "R" ) export("row_sums", "col_sums", "row_means", "col_means" ) S3method("row_sums", "default") S3method("row_sums", "simple_triplet_matrix") S3method("row_sums", "dgTMatrix") S3method("row_sums", "dgCMatrix") S3method("col_sums", "default") S3method("col_sums", "simple_triplet_matrix") S3method("col_sums", "dgTMatrix") S3method("col_sums", "dgCMatrix") S3method("row_means", "default") S3method("row_means", "simple_triplet_matrix") S3method("row_means", "dgTMatrix") S3method("row_means", "dgCMatrix") S3method("col_means", "default") S3method("col_means", "simple_triplet_matrix") S3method("col_means", "dgTMatrix") S3method("col_means", "dgCMatrix") export("row_norms", "col_norms") ## export("tcrossprod_simple_triplet_matrix", "crossprod_simple_triplet_matrix", "matprod_simple_triplet_matrix") export("rowapply_simple_triplet_matrix", "colapply_simple_triplet_matrix", "crossapply_simple_triplet_matrix", "tcrossapply_simple_triplet_matrix") ## export("rollup") S3method("rollup", "default") S3method("rollup", "matrix") S3method("rollup", "array") S3method("rollup", "simple_sparse_array") S3method("rollup", "simple_triplet_matrix") ## Simple sparse array stuff export("as.simple_sparse_array", "is.simple_sparse_array", "simple_sparse_array", "simple_sparse_zero_array", ## "simplify_simple_sparse_array", "reduce_simple_sparse_array", "drop_simple_sparse_array", ## "extend_simple_sparse_array", "abind_simple_sparse_array" ) S3method("[", "simple_sparse_array") S3method("[<-", "simple_sparse_array") S3method("Math", "simple_sparse_array") S3method("Summary", "simple_sparse_array") S3method("as.array", "simple_sparse_array") S3method("as.array", "simple_triplet_matrix") S3method("as.simple_sparse_array", "simple_sparse_array") S3method("as.simple_sparse_array", "simple_triplet_matrix") S3method("as.simple_sparse_array", "array") S3method("as.simple_sparse_array", "matrix") S3method("as.simple_sparse_array", "default") S3method("as.vector", "simple_sparse_array") S3method("dim", "simple_sparse_array") S3method("dim<-", "simple_sparse_array") S3method("dimnames", "simple_sparse_array") S3method("dimnames<-", "simple_sparse_array") S3method("is.numeric", "simple_sparse_array") S3method("mean", "simple_sparse_array") S3method("print", "simple_sparse_array") if(getRversion() >= "2.13.0") { S3method("aperm", "simple_triplet_matrix") S3method("aperm", "simple_sparse_array") } ## Sparse matrix format readers and writers export("read_stm_CLUTO", "write_stm_CLUTO", "read_stm_MC", "write_stm_MC" ) slam/R/0000755000175100001440000000000012262026562011430 5ustar hornikusersslam/R/stm.R0000644000175100001440000000655112253654212012364 0ustar hornikusers ## CB 2009/5,6,10 2010/6 2013/10 ## NOTE the C code does not use long double for accumulation. .means_simple_triplet_matrix <- function(x, DIM, na.rm) { s <- .Call(R_sums_stm, x, DIM, na.rm) n <- c(x$nrow, x$ncol)[-DIM] if (na.rm) { x$v <- is.na(x$v) nna <- .Call(R_sums_stm, x, DIM, FALSE) s / (n - nna) } else s / n } ## R interfaces row_sums <- function(x, na.rm = FALSE, dims = 1, ...) UseMethod("row_sums") row_sums.default <- function(x, na.rm = FALSE, dims = 1, ...) base::rowSums(x, na.rm, dims, ...) row_sums.simple_triplet_matrix <- function(x, na.rm = FALSE, dims = 1, ...) .Call(R_sums_stm, x, 1L, na.rm) row_sums.dgCMatrix <- function(x, na.rm = FALSE, dims = 1, ...) Matrix::rowSums(x, na.rm = na.rm, dims = dims, ...) row_sums.dgTMatrix <- function(x, na.rm = FALSE, dims = 1, ...) Matrix::rowSums(x, na.rm = na.rm, dims = dims, ...) col_sums <- function(x, na.rm = FALSE, dims = 1, ...) UseMethod("col_sums") col_sums.default <- function(x, na.rm = FALSE, dims = 1, ...) base::colSums(x, na.rm, dims, ...) col_sums.simple_triplet_matrix <- function(x, na.rm = FALSE, dims = 1, ...) .Call(R_sums_stm, x, 2L, na.rm) col_sums.dgCMatrix <- function(x, na.rm = FALSE, dims = 1, ...) Matrix::colSums(x, na.rm = na.rm, dims = dims, ...) col_sums.dgTMatrix <- function(x, na.rm = FALSE, dims = 1, ...) Matrix::colSums(x, na.rm = na.rm, dims = dims, ...) row_means <- function(x, na.rm = FALSE, dims = 1, ...) UseMethod("row_means") row_means.default <- function(x, na.rm = FALSE, dims = 1, ...) base::rowMeans(x, na.rm, dims, ...) row_means.simple_triplet_matrix <- function(x, na.rm = FALSE, dims = 1, ...) .means_simple_triplet_matrix(x, DIM = 1L, na.rm) row_means.dgCMatrix <- function(x, na.rm = FALSE, dims = 1, ...) Matrix::rowMeans(x, na.rm = na.rm, dims = dims, ...) row_means.dgTMatrix <- function(x, na.rm = FALSE, dims = 1, ...) Matrix::rowMeans(x, na.rm = na.rm, dims = dims, ...) col_means <- function(x, na.rm = FALSE, dims = 1, ...) UseMethod("col_means") col_means.default <- function(x, na.rm = FALSE, dims = 1, ...) base::colMeans(x, na.rm, dims, ...) col_means.simple_triplet_matrix <- function(x, na.rm = FALSE, dims = 1, ...) .means_simple_triplet_matrix(x, DIM = 2L, na.rm) col_means.dgCMatrix <- function(x, na.rm = FALSE, dims = 1, ...) Matrix::colMeans(x, na.rm = na.rm, dims = dims, ...) col_means.dgTMatrix <- function(x, na.rm = FALSE, dims = 1, ...) Matrix::colMeans(x, na.rm = na.rm, dims = dims, ...) row_norms <- function(x, p = 2) { if(p == 2) sqrt(row_sums(x ^ 2)) else if(p == 1) row_sums(abs(x)) else if(p == Inf) c(rollup(abs(x), 2L, FUN = max)) else row_sums(abs(x) ^ p) ^ (1/p) } col_norms <- function(x, p = 2) { if(p == 2) sqrt(col_sums(x ^ 2)) else if(p == 1) col_sums(abs(x)) else if(p == Inf) c(rollup(abs(x), 1L, FUN = max)) else col_sums(abs(x) ^ p) ^ (1/p) } ## .nnzero <- function(x, scale = FALSE) { v <- c("simple_triplet_matrix", "simple_sparse_array") if (inherits(x, v)) v <- x$v else { x <- as.array(x) v <- x } v <- v == vector(typeof(v), 1L) v <- v + 1L n <- length(v) v <- tabulate(v, 2L) v <- c(v, n - sum(v)) names(v) <- c("nnzero", "nzero", NA) if (scale) v <- v / prod(dim(x)) v } ### slam/R/reduce.R0000644000175100001440000000632312032330073013014 0ustar hornikusers### ## For performance reasons the constructor does not ## check for multiple or 'zero' elements. ## ## Argument 'strict' provides a choice whether to ## enforce these constraints, or to reduce 'multiples' ## to NA (unless they all are identical) and remove ## 'zeros'. ## reduce_simple_sparse_array <- function(x, strict = FALSE, order = FALSE) { if (!.Call(R__valid_ssa, x)) stop("'x' not of class 'simple_sparse_array'") I <- x$i if (length(i <- attributes(I)) > 1L) dim(I) <- i$dim rm(i) V <- .Call(R_unattr, x$v) if (length(V)) { ## reduce multiple entries i <- .Call(R_match_matrix, I, NULL, NULL) if (length(i[[1L]]) > length(i[[2L]])) { if (strict) stop("multiple entries") I <- I[i[[2L]],, drop = FALSE] i <- structure( i[[1L]], levels = seq_len(dim(I)[1L]), class = "factor" ) V <- split(V, i) rm(i) names(V) <- NULL V <- sapply(V, function(x) if (length(x) > 1L) { x <- as.list(x) if (all(sapply(x[-1L], identical, x[[1L]]))) x[[1L]] else NA } else x, USE.NAMES = FALSE) warning("NAs introduced by reduction") } else rm(i) ## remove 'zero' entries i <- which(V == vector(typeof(V), 1L)) if (strict) stop("zero entries") if (length(i)) { i <- -i V <- V[i] I <- I[i,, drop = FALSE] } rm(i) ## order entries if (order) { i <- do.call("order", rev(.Call(R_split_col, I))) if (!identical(i, seq_along(i))) { V <- V[i] I <- I[i,, drop = FALSE] } rm(i) } } D <- as.vector(x$dim) N <- x$dimnames N <- if (!length(N) || (is.null(names(N)) && all(sapply(N, is.null)))) NULL else lapply(N, as.vector) simple_sparse_array(I, V, D, N) } ## drop_simple_sparse_array <- function(x) { if (!is.simple_sparse_array(x)) stop("'x' not of class 'simple_sparse_array'") dx <- x$dim if (any(dx == 0L)) return(vector(typeof(x$v), 0L)) ## sanitize k <- which(dx == 1L) if (length(k) == length(dx)) return(x$v) if (length(k)) { k <- -k x$i <- x$i[, k, drop = FALSE] x$dim <- dx[k] if (!is.null(x$dimnames)) x$dimnames <- x$dimnames[k] } x } ## see simplify2array simplify_simple_sparse_array <- function(x, higher = TRUE) { if (!is.simple_sparse_array(x)) stop("'x' not of class 'simple_sparse_array'") V <- x$v if (is.atomic(V) || !length(V)) return(x) i <- unique(unlist(lapply(V, length))) ## FIXME not implemented if (length(i) > 1L) return(x) if (!i) return(x) if (i == 1L) { x$v <- unlist(V, recursive = FALSE) return(x) } I <- x$i D <- x$dim N <- x$dimnames if (higher && length(d <- unique(lapply(V, dim))) == 1L && !is.null(d <- unlist(d))) { i <- d n <- dimnames(V[[1L]]) } else if (!is.null(n <- names(V[[1L]]))) n <- list(n) V <- unlist(V, recursive = FALSE) ## FIXME not optimized for (k in rev(i)) { l <- dim(I)[1L] if (k > 1L) I <- apply(I, 2L, rep, each = k) I <- cbind(rep(seq.int(k), l), I) } if (!is.null(N)) { if (!is.list(n)) n <- list(n) N <- c(n, N) } else if (!is.null(n)) N <- list(n, vector("list", length(D))) D <- c(i, D) simple_sparse_array(I, V, D, N) } ### slam/R/foreign.R0000644000175100001440000001365112027360170013205 0ustar hornikusersread_stm_CLUTO <- function(file) { ## Read CLUTO sparse matrix format. ## Read in the matrix file. l <- strsplit(readLines(file, warn = FALSE), "[[:space:]]+") l <- lapply(l, as.double) l <- lapply(l, na.omit) ## Extract header information. nRow <- as.integer(l[[1L]][1L]) nCol <- as.integer(l[[1L]][2L]) nElem <- l[[1L]][3L] ## Remove header l <- l[-1L] ## Compute i, j, and v slots for a simple_triplet_matrix. rowLen <- sapply(l, length) l <- unlist(l) i <- rep.int(seq_len(nRow), rowLen / 2) j <- l[seq.int(1, length(l), by = 2)] v <- l[seq.int(2, length(l), by = 2)] ## Sanity check if(nElem != length(v)) stop("invalid matrix format") ## Generate sparse matrix m <- simple_triplet_matrix(i, j, v, nRow, nCol) if(is.character(file)) { ## Use col labels file if available and valid. if(file.exists(f <- sprintf("%s.clabel", file))) { lines <- readLines(f) if(length(lines) == nCol) colnames(m) <- lines } ## Use row labels file if available and valid. if(file.exists(f <- sprintf("%s.rlabel", file))) { lines <- readLines(f) if(length(lines) == nRow) rownames(m) <- lines } ## Use row class file if available. if(file.exists(f <- sprintf("%s.rclass", file))) { lines <- readLines(f) if(length(lines) == nRow) attr(m, "rclass") <- lines } } m } write_stm_CLUTO <- function(x, file) { ## Write CLUTO sparse matrix format. x <- as.simple_triplet_matrix(x) ## Generate header. header <- paste(x$nrow, x$ncol, length(x$v)) ## Generate content. content <- Map(function(u, v) paste(u, v, collapse = " "), split(x$j, x$i), split(x$v, x$i)) ## Write out. writeLines(c(header, unlist(content)), file) if(is.character(file)) { if(!is.null(rnms <- rownames(x))) writeLines(rnms, sprintf("%s.rlabel", file)) if(!is.null(cnms <- colnames(x))) writeLines(cnms, sprintf("%s.clabel", file)) } } read_stm_MC <- function(file, scalingtype = NULL) { ## Read the CCS format variant employed by MC ## (http://www.cs.utexas.edu/users/dml/software/mc/) and related ## software projects at cs.utexas.edu such as gmeans. ## The main MC web page points to ## http://www.cs.utexas.edu/users/jfan/dm/README.html ## which no longer seems to exist: but the MC sources contain a file ## README with some information. ## The basic CCS format is documented in ## http://www.cs.utexas.edu/users/inderjit/Resources/sparse_matrices. d <- scan(sprintf("%s_dim", file), what = integer(0), quiet = TRUE) nr <- d[1L] nc <- d[2L] i <- scan(sprintf("%s_row_ccs", file), what = integer(0), quiet = TRUE) p <- scan(sprintf("%s_col_ccs", file), what = integer(0), quiet = TRUE) if(is.null(scalingtype)) { ## The name of the file with the non-zero entries varies with ## the t-f-n scaling pattern employed (and possibly an 'i' at ## the end indicating that row and columne scaling were ## performed independently: scalingtype <- expand.grid(c("t", "l"), c("x", "f", "e", "1"), c("x", "n", "1"), c("", "i")) ## (Not sure whether all combinations really make sense.) scalingtype <- apply(scalingtype, 1L, paste, collapse = "") } files <- sprintf("%s_%s_nz", file, scalingtype) pos <- which(file.exists(files))[1L] x <- scan(files[pos], what = numeric(0), quiet = TRUE) scalingtype <- scalingtype[pos] ## Sanity check if(d[3L] != length(x)) stop("invalid matrix format") ## In special cases (e.g., when CCS was produced by the MC toolkit, ## see http://userweb.cs.utexas.edu/users/jfan/dm/README.html) we ## can also infer the row and col names. rnms <- if(file.exists(f <- sprintf("%s_words", file))) { readLines(f)[seq(from = 2L, length.out = nr)] } else NULL cnms <- if(file.exists(f <- sprintf("%s_docs", file))) { sub("^[^ ]*: ", "", readLines(f)) } else NULL m <- simple_triplet_matrix(i + 1L, rep.int(seq_len(nc), diff(p)), x, nr, nc, list(rnms, cnms)) attr(m, "scalingtype") <- scalingtype m } write_stm_MC <- function(x, file) { ## Write CCS sparse matrix format as used by MC and other software ## projects from cs.utexas.edu such as gmeans. ## ## This said: ## Gmeans uses a compressed column storage (CCS) ## See http://www.cs.utexas.edu/users/inderjit/Resources/sparse_matrices ## ## However since Gmeans clusters along columns, and the input for ## our skmeans clusters along rows, we would need to transpose the ## matrix first, and then write it to CCS. ## ## Instead we could directly write to compressed row storage (CRS) ## to avoid the transpose ## See ## http://netlib.org/linalg/html_templates/node92.html#SECTION00931200000000000000 ## Does this mean we should not transpose in general, but when ## writing out for gmeans in skmeans only? ## x <- t(as.simple_triplet_matrix(x)) # Based on slam/work/Matrix.R ind <- order(x$j, x$i) write(paste(nrow(x), ncol(x), length(x$v)), sprintf("%s_dim", file)) write(x$i[ind] - 1L, sprintf("%s_row_ccs", file), sep = "\n") write(c(0L, cumsum(tabulate(x$j[ind], x$ncol))), sprintf("%s_col_ccs", file), sep = "\n") write(x$v[ind], sprintf("%s_tfn_nz", file), sep = "\n") ## Could also try to write a _docs file. ## But what does the 2nd half of the _words files contain? } slam/R/subassign.R0000644000175100001440000001043512103507072013546 0ustar hornikusers## CB 2012/9 ## ## FIXME extending might be useful unless implemented ## as for dense arrays. ## `[<-.simple_sparse_array` <- function(x, ..., value) { if (!length(value)) stop("replacement has length zero") nd <- length(x$dim) pd <- prod(x$dim) ## Disable features that may exhaust resources. .protect <- pd > 16777216L na <- nargs() if (na == 3L && missing(..1)) if (.protect) stop("Empty subscripting disabled.") else return( `[<-.simple_sparse_array`(x, seq_len(pd), value = value) ) ## Single index subscripting. if (na == 3L) { I <- ..1 if (!is.numeric(I)) stop("Only numeric subscripting is implemented.") if (!length(I)) return(x) ## Missing values in subscripts. k <- is.na(I) if (any(k)) if (length(value) == 1L) I[k] <- 0L else stop("NAs are not allowed in subscripted assignments") rm(k) ## Vector subscripting. if (!is.matrix(I)) { ## 52-bit safe if (pd > 4503599627370496) stop("Vector subscripting disabled for this object.") ## Map. if (is.double(I)) I <- trunc(I) if (all(I >= 0L)) { ## Remove zero subscripts. I <- I[I > 0L] if (!length(I)) return(x) if (any(I > pd)) stop("Extending is not implemented.") } else { if (.protect) stop("Negative subscripting disabled for this object.") if (all(I <= 0L)) { ## NOTE this fails if NAs are introduced by ## coercion. I <- seq_len(pd)[I] } else stop("only 0's may be mixed with negative subscripts") } ## Expand. I <- arrayInd(I, .dim = x$dim) } else ## NOTE as the other replacement rules are no less ## confusing we allow this, too. if (ncol(I) != nd) { dim(I) <- NULL return( `[<-.simple_sparse_array`(x, I, value = value) ) } ## Map. if (is.double(I)) I <- trunc(I) if (any(I < 0L)) stop("negative values are not allowed in a matrix subscript") ## Remove rows with zero subscripts. I <- I[.Call(R_all_row, I > 0L, FALSE),, drop = FALSE] if (!nrow(I)) return(x) ## NOTE NAs cannot be introduced by coercion as ## long as the bounds are integer. if (any(I > rep(x$dim, each = nrow(I)))) stop("subscript out of bounds") storage.mode(I) <- "integer" } else { if (na != nd + 2L) stop("incorrect number of dimensions") ## Get indices. args <- vector("list", na - 2L) for (k in seq_along(args)) { n <- as.name(sprintf("..%i", k)) if (!do.call(missing, list(n))) args[[k]] <- eval(n) else if (.protect) stop("Missing dimensions disabled for this object.") else args[[k]] <- seq_len(x$dim[k]) } if (!all(sapply(args, is.numeric))) stop("Only numeric subscripting is implemented.") ## Replace negative subscripts. for (k in seq_along(args)) { ## Map. if (is.double(args[[k]])) args[[k]] <- trunc(args[[k]]) if (.protect) { if (any(args[[k]] < 0L)) stop("Negative subscripting disabled for this object.") } else if (all(args[[k]] <= 0L)) args[[k]] <- seq_len(x$dim[k])[args[[k]]] else if (!all(args[[k]] >= 0L)) stop("only 0's may be mixed with negative subscripts") } ## Expand. args <- matrix( unlist(expand.grid(args), use.names = FALSE), ncol = length(args) ) return( `[<-.simple_sparse_array`(x, args, value = value) ) } ## Recycling. if (nrow(I) %% length(value)) warning("number of items to replace is not a multiple of replacement length") V <- rep(value, length.out = nrow(I)) ## Merge. ## ## Emulates subsequent assignments of a sequence ## of replacement values with duplicate cell ## indexes. I <- rbind(x$i, I) k <- .Call(R_match_matrix, I, NULL, NULL) k <- !duplicated(k[[1L]], fromLast = TRUE) I <- I[k,, drop = FALSE] V <- c(x$v, V)[k] ## Remove ZERO entries. k <- V == vector(typeof(V), 1L) if (any(k)) { k <- !k I <- I[k,, drop = FALSE] V <- V[k] } simple_sparse_array( v = V, i = I, dim = x$dim, dimnames = x$dimnames ) } ## `[<-.simple_triplet_matrix` <- function(x, ..., value) { x <- `[<-.simple_sparse_array`(as.simple_sparse_array(x), ..., value = value) if (inherits(x, "simple_sparse_array")) x <- as.simple_triplet_matrix(x) x } ### slam/R/apply.R0000644000175100001440000000672012262026562012705 0ustar hornikusers## CB 2013/12 colapply_simple_triplet_matrix <- function(x, FUN, ...) { FUN <- match.fun(FUN) out <- .External(R_col_apply_stm, x, FUN, ...) if (length(out)) { if (all(unlist(lapply(out, length)) == 1L)) out <- unlist(out, recursive = FALSE, use.names = FALSE) names(out) <- colnames(x) } else ## NOTE we always supplie as matrix in case dimensions ## must conform with further arguments. storage.mode(out) <- typeof(FUN(as.matrix(x), ...)) out } rowapply_simple_triplet_matrix <- function(x, FUN, ...) { FUN <- match.fun(FUN) if (!is.simple_triplet_matrix(x)) stop("'x' not of class simple_striplet_matrix") colapply_simple_triplet_matrix(t(x), FUN, ...) } ## FIXME a workaround for a proper C implementation. crossapply_simple_triplet_matrix <- function(x, y = NULL, FUN, ...) { FUN <- match.fun(FUN) if (is.null(y)) { if (!is.simple_triplet_matrix(x)) stop("'x' not of class simple_triplet_matrix") Y <- x out <- colapply_simple_triplet_matrix(x, function(x) { out <- colapply_simple_triplet_matrix(Y, FUN, x, ...) Y <<- Y[, -1L] out }) out <- unlist(out, recursive = FALSE, use.names = FALSE) Y <- simple_triplet_zero_matrix(x$ncol) Y <- row(Y) >= col(Y) out[Y] <- out out <- matrix(out, nrow = x$ncol, ncol = x$ncol, byrow = TRUE, dimnames = if (!is.null(colnames(x))) list(colnames(x), colnames(x)) ) out[Y] <- t(out)[Y] return(out) } if (is.simple_triplet_matrix(y)) { if (!is.simple_triplet_matrix(x)) return( t(crossapply_simple_triplet_matrix(y, as.matrix(x), function(y, x) FUN(x, y, ...))) ) if (x$nrow != y$nrow) stop("the numer of rows of 'x' and 'y' do not conform") ## Fix asymmetric performance. if (x$ncol > y$ncol) return( t(crossapply_simple_triplet_matrix(y, x, function(y, x) FUN(x, y, ...))) ) if (y$ncol > 0L && x$ncol > 0L) { out <- colapply_simple_triplet_matrix(x, function(x) colapply_simple_triplet_matrix(y, function(y) FUN(x, y, ...))) } else out <- colapply_simple_triplet_matrix(x[, 0L], FUN, as.matrix(y[, 0L]), ...) } else { if (!is.simple_triplet_matrix(x)) stop("'x, y' not of class simple_triplet_matrix") y <- as.matrix(y) if (x$nrow != nrow(y)) stop("the numer of rows of 'x' and 'y' do not conform") if (ncol(y) > 0L && x$ncol > 0L) { Y <- split(y, factor(col(y), levels = seq_len(ncol(y)))) out <- colapply_simple_triplet_matrix(x, function(x) { out <- lapply(Y, function(y) FUN(x, y, ...)) if (all(unlist(lapply(out, length)) == 1L)) out <- unlist(out, recursive = FALSE, use.names = FALSE) out }) rm(Y) } else out <- colapply_simple_triplet_matrix(x[, 0L], FUN, y[, 0L, drop = FALSE], ...) } out <- unlist(out, recursive = FALSE, use.names = FALSE) out <- matrix(out, nrow = x$ncol, ncol = ncol(y), byrow = TRUE, dimnames = if (!is.null(colnames(x)) || !is.null(colnames(y))) list(colnames(x), colnames(y)) ) out } tcrossapply_simple_triplet_matrix <- function(x, y = NULL, FUN, ...) { FUN <- match.fun(FUN) if (is.simple_triplet_matrix(x)) crossapply_simple_triplet_matrix(t(x), if (is.null(y)) y else if (is.simple_triplet_matrix(y)) t(y) else t(as.matrix(y)), FUN, ... ) else if (is.simple_triplet_matrix(y)) crossapply_simple_triplet_matrix(t(as.matrix(x)), t(y), FUN, ...) else stop("'x, y' not of class simple_triplet_matrix") } ### slam/R/array.R0000644000175100001440000002355012212432014012662 0ustar hornikusers## A simple class for sparse arrays. ## Not very useful yet: need at least a subscript method. ## (Unfortunately, additional methods such as for rowSums/colSums or ## apply, etc., are not straightforward to add in an S3 world ...) simple_sparse_array <- function(i, v, dim = NULL, dimnames = NULL) { ## See examples storage.mode(i) <- "integer" if (!is.matrix(i)) dim(i) <- c(length(i), 1L) ## ## Add some sanity checking eventually ... ## i should be a matrix of indices (non-"zero" entries). ## v should be a "vector" of non-zero values, with length equal to ## the number of rows of i. ## if(is.null(dim)) dim <- if(NROW(i)) apply(i, 2L, max) else c(0L, 0L) ## ## Add checks for dimnames: should be NULL or a list of entries ## which are either NULL or character vectors as long as the ## corresponding dim. ## ssa <- list(i = i, v = v, dim = as.integer(dim), dimnames = dimnames) class(ssa) <- "simple_sparse_array" ## Note that this should never be true as it implies that either ## the class is wrong or the container is malformed. if (!.Call(R__valid_ssa, ssa)) stop("failed to create a valid 'simple_sparse_array' object") ssa } as.simple_sparse_array <- function(x) UseMethod("as.simple_sparse_array") as.simple_sparse_array.simple_sparse_array <- identity as.simple_sparse_array.array <- function(x) { x <- unclass(x) dx <- dim(x) if(!prod(dx)) return(simple_sparse_array(matrix(integer(), 0L, length(dx)), c(x), dx, dimnames(x))) ind <- which(is.na(x) | (x != vector(typeof(x), 1L)), arr.ind = TRUE) dimnames(ind) <- NULL simple_sparse_array(ind, x[ind], dx, dimnames(x)) } as.simple_sparse_array.matrix <- as.simple_sparse_array.array as.simple_sparse_array.simple_triplet_matrix <- function(x) simple_sparse_array(cbind(x$i, x$j), x$v, c(x$nrow, x$ncol), dimnames(x)) as.simple_sparse_array.default <- function(x) as.simple_sparse_array(unclass(as.array(x))) as.array.simple_sparse_array <- function(x, ...) { v <- x$v dim <- x$dim y <- array(vector(typeof(v), 1L), dim = dim, dimnames = x$dimnames) y[x$i] <- v y } is.simple_sparse_array <- function(x) inherits(x, "simple_sparse_array") Math.simple_sparse_array <- function(x, ...) { ## Functions in the Math group mapping 0 to 0: funs <- c("abs", "sign", "sqrt", "floor", "ceiling", "trunc", "round", "signif") if(is.na(match(as.character(.Generic), funs))) stop(gettextf("Generic '%s' not defined for \"%s\" objects.", .Generic, .Class), domain = NA) x$v <- get(.Generic)(x$v, ...) x } Summary.simple_sparse_array <- function(..., na.rm = FALSE) { v <- unlist(lapply(list(...), function(e) { v <- as.simple_sparse_array(e)$v if(length(v) < prod(dim(e))) v <- c(v, vector(typeof(v), 1L)) v }), recursive = FALSE) do.call(.Generic, list(v, na.rm = na.rm)) } dim.simple_sparse_array <- function(x) x$dim `dim<-.simple_sparse_array` <- function(x, value) { value <- as.integer(value) if(!length(value) || any(is.na(value))) stop("invalid dim replacement value") dx <- dim(x) if(prod(value) != prod(dx)) stop("invalid dim replacement value") x$i <- arrayInd(.Call(R_vector_index, x$dim, x$i), value) x$dim <- value x$dimnames <- NULL x } dimnames.simple_sparse_array <- function(x) x$dimnames ## FIXME we now have drop_simple_sparse_array `[.simple_sparse_array` <- function(x, ...) { ## Note that calling x[] with a simple sparse array x will call the ## subscript method with args x and missing ... na <- nargs() if((na == 1L) || (na == 2L) && missing(..1)) return(x) nd <- length(x$dim) ## Note there is a limit to representing integer numbers as ## doubles. spos <- function(i) { if(!nrow(i)) return(vector(mode = typeof(i), length = 0L)) ## Scalar positions of array index matrices i in the usual row ## major ordering of arrays. if(ncol(i) > 1L) { ## This may not work on systems with BLAS issues ## as.vector(tcrossprod(c(1L, cumprod(x$dim[-nd])), i - 1L)) + 1L 1L + row_sums((i - 1L) * rep(c(1L, cumprod(x$dim)[-nd]), each = nrow(i))) } else as.vector(i) } if(na == 2L) { i <- ..1 ## Single index subscripting. if(is.logical(i)) stop("Logical subscripting currently not implemented.") else if(is.character(i)) stop("Character subscripting currently not implemented.") else if(!is.matrix(i)) { ## 52-bit safe if(prod(x$dim) > 4503599627370496) stop("Numeric vector subscripting disabled for this object.") ## Shortcut if(!length(i)) return(vector(mode = typeof(x$v), length = 0L)) ## Let's hope we have a vector. ## What if we have both negatives and positives? if(is.double(i)) i <- trunc(i) if(all(i >= 0, na.rm = TRUE)) { i <- i[i > 0] out <- vector(mode = typeof(x$v), length = length(i)) if(length(out)) { ## Missing values. is.na(i) <- i > prod(x$dim) is.na(out) <- is.na(i) i <- match(i, spos(x$i), 0L) out[i > 0L] <- x$v[i] } } else if(!any(is.na(i)) && all(i <= 0)) { if(prod(x$dim) > 16777216L) stop("Negative vector subsripting disabled for this object.") out <- vector(mode = typeof(x$v), prod(x$dim)) out[spos(x$i)] <- x$v ## NOTE this fails if NAs are introduced by ## coercion to integer. out <- out[i] } else stop("Cannot mix positive and negative subscripts.") } else { ## Shortcut if(!nrow(i)) return(vector(mode = typeof(x$v), length = 0L)) ## Ignore dimensions. if(ncol(i) != nd) return(do.call("[.simple_sparse_array", list(x = x, as.vector(i)))) ## Note that negative values are not allowed in a matrix ## subscript. if(is.double(i)) i <- trunc(i) if(any(i < 0, na.rm = TRUE)) stop("Invalid subscript.") k <- .Call(R_all_row, i > 0, FALSE) i <- i[k, , drop = FALSE] out <- vector(mode = typeof(x$v), length = nrow(i)) if(length(out)) { if(any(i > rep(x$dim, each = nrow(i)), na.rm = TRUE)) stop("subscript out of bounds") ## Missing values. k <- k[k] is.na(out) <- is.na(k) rm(k) ## This is not really the fastest way to match rows, but is ## there an obvious better one? ## pos <- match(split(i, row(i)), split(x$i, row(x$i)), 0L) storage.mode(i) <- "integer" i <- .Call(R_match_matrix, x$i, i, 0L)[[2L]] out[i > 0L] <- x$v[i] } } } else { if(na != (nd + 1L)) stop("Incorrect number of dimensions.") ## Get indices. args <- vector("list", na - 1L) for(k in seq_along(args)) { n <- as.name(sprintf("..%i", k)) if (!do.call(missing, list(n))) args[[k]] <- eval(n) } ## Ready to go. dx <- x$dim pos <- rep.int(TRUE, length(x$v)) ind <- vector("list", length = nd) for(k in seq_len(nd)) { i <- args[[k]] # Given indices. if(is.null(i)) { ind[[k]] <- seq_len(dx[k]) next } else if(!is.numeric(i)) stop("Only numeric multi-index subscripting is implemented.") else { if (any(is.na(i))) stop("NA indices currently not allowed") if(is.double(i)) i <- trunc(i) if(all(i >= 0)) { i <- i[i > 0] if(any(duplicated(i))) stop("Repeated indices currently not allowed.") if(any(i > dx[k])) stop("subscript out of bounds") } else if(all(i <= 0)) ## NOTE this fails if NAs are introduced by ## coercion to integer. i <- seq_len(dx[k])[i] else stop("Cannot mix positive and negative subscripts.") ind[[k]] <- i dx[k] <- length(i) j <- match(x$i[, k], i, 0L) x$i[j > 0L, k] <- seq_along(i)[j] pos <- pos & (j > 0L) } } if(!is.null(dnx <- x$dimnames)) dnx[] <- Map("[", dnx, ind) out <- simple_sparse_array(x$i[pos, , drop = FALSE], x$v[pos], dx, dnx) } out } ## ## Add duplicated and unique methods for simple sparse arrays along the ## lines of the corresponding methods for simple triplet matrices. ## print.simple_sparse_array <- function(x, ...) { writeLines(gettextf("A simple sparse array of dimension %s.", paste(dim(x), collapse = "x"))) invisible(x) } mean.simple_sparse_array <- function(x, ...) { sum(x$v) / prod(dim(x)) } aperm.simple_sparse_array <- function(a, perm = NULL, ...) { s <- seq_along(a$dim) if(is.null(perm)) perm <- rev(s) else { perm <- if(is.character(perm)) match(perm, names(a$dimnames)) else if(is.numeric(perm)) match(perm, s) else NULL if(length(perm) != length(s) || any(is.na(perm))) stop("Invalid permutation.") } simple_sparse_array(a$i[, perm, drop = FALSE], a$v, a$dim[perm], a$dimnames[perm]) } as.vector.simple_sparse_array <- function(x, mode = "any") as.vector(as.array(x), mode) simple_sparse_zero_array <- function(dim, mode = "double") { ld <- length(dim) if (!ld) stop("'dim' must have positive length") simple_sparse_array(matrix(integer(), 0L, ld), vector(mode, 0L), dim) } slam/R/crossprod.R0000644000175100001440000000474312262026562013601 0ustar hornikusers ## NOTE the C code must always check for special values and ## therefore has control over how to proceed. For now ## it calls the bailout function below. ## ## For verbose information set the verbose argument to ## TRUE. Transposition of the return value (!) is only ## implemented for dense. ## ## The general case is now also handled in C. Runtime ## could be further improved if the data need not be ## ordered (see the C code). .tcrossprod_simple_triplet_matrix <- function(x, y = NULL, transpose = FALSE, bailout = TRUE, verbose = FALSE) { if (!is.simple_triplet_matrix(x)) stop("'x' not of class simple_triplet_matrix") if (is.null(y) || is.simple_triplet_matrix(y)) { if (transpose) stop("'transpose' not implemented") .Call(R_tcrossprod_stm_stm, x, y, if (bailout) environment(.tcrossprod_simple_triplet_matrix), verbose ) } else .Call(R_tcrossprod_stm_matrix, x, as.matrix(y), if (bailout) environment(.tcrossprod_simple_triplet_matrix), verbose, transpose ) } .tcrossprod_bailout <- function(x, y, transpose) { if (transpose) ## see above base::tcrossprod(y, as.matrix(x)) else base::tcrossprod(as.matrix(x), if (is.null(y)) y else as.matrix(y) ) } ## Used by package skmeans. .ttcrossprod_simple_triplet_matrix <- function(x, y = NULL) .tcrossprod_simple_triplet_matrix(x, y, TRUE) ## tcrossprod_simple_triplet_matrix <- function(x, y = NULL) { if (is.simple_triplet_matrix(x)) .tcrossprod_simple_triplet_matrix(x, y) else if (is.simple_triplet_matrix(y)) .tcrossprod_simple_triplet_matrix(y, as.matrix(x), TRUE) else stop("'x, y' not of class simple_triplet_matrix") } crossprod_simple_triplet_matrix <- function(x, y = NULL) { if (is.simple_triplet_matrix(x)) .tcrossprod_simple_triplet_matrix(t(x), if (is.null(y)) y else if (is.simple_triplet_matrix(y)) t(y) else t(as.matrix(y)) ) else if (is.simple_triplet_matrix(y)) .tcrossprod_simple_triplet_matrix(t(y), t(as.matrix(x)), TRUE) else stop("'x, y' not of class simple_triplet_matrix") } matprod_simple_triplet_matrix <- function(x, y) { if (is.simple_triplet_matrix(x)) .tcrossprod_simple_triplet_matrix(x, if (is.simple_triplet_matrix(y)) t(y) else t(as.matrix(y)) ) else if (is.simple_triplet_matrix(y)) .tcrossprod_simple_triplet_matrix(t(y), as.matrix(x), TRUE) else stop("'x, y' not of class simple_triplet_matrix") } ## slam/R/abind.R0000644000175100001440000000466111753474631012647 0ustar hornikusers ## extend_simple_sparse_array <- function(x, MARGIN = 0L) { if (!is.simple_sparse_array(x)) stop("'x' not of class 'simple_sparse_array'") k <- MARGIN < 0L MARGIN[k] <- -MARGIN[k] -1L k <- MARGIN[1L] ## extend D <- c(1L, x$dim) I <- cbind(1L, x$i) N <- x$dimnames if (!is.null(N)) N <- c(list(NULL), N) if (k > 0L) if (k > length(D)) stop("'MARGIN' invalid") else { ## order i <- order(c(k + 1L, seq.int(length(D) - 1L))) D <- D[i] I <- I[,i] if (!is.null(N)) N <- N[i] } x <- simple_sparse_array(I, x$v, D, N) rm(I, D, N) while (length(MARGIN <- MARGIN[-1L])) { k <- MARGIN > k MARGIN[k] <- MARGIN[k] + 1L x <- extend_simple_sparse_array(x, MARGIN[[1L]]) } x } ## abind_simple_sparse_array <- function(..., MARGIN = 1L) { if (length(MARGIN) != 1L || MARGIN == 0L) stop("'MARGIN' invalid") args <- list(...) if (length(args)) args <- args[!sapply(args, is.null)] if (!length(args)) return(NULL) x <- as.simple_sparse_array(args[[1L]]) if (MARGIN < 0L) x <- extend_simple_sparse_array(x, MARGIN) if (length(args) == 1L) return(x) for (y in args[-1L]) { y <- as.simple_sparse_array(y) if (MARGIN < 0L) y <- extend_simple_sparse_array(y, MARGIN) m <- abs(MARGIN) if (length(y$dim) == length(x$dim) - 1L) y <- extend_simple_sparse_array(y, -min(m, length(x$dim))) else if (length(y$dim) - 1L == length(x$dim)) { x <- extend_simple_sparse_array(x, -min(m, length(y$dim))) } else if (length(y$dim) != length(x$dim)) stop("lengths of 'dim' do not conform") D <- x$dim m <- min(length(D), m) if (!identical(y$dim[-m], D[-m])) stop("common parts of 'dim' do not conform") if (vector(typeof(x$v), 1L) != vector(typeof(y$v), 1L)) stop("definitions of ZERO of 'v' do not conform") V <- c(x$v, y$v) I <- y$i I[, m] <- I[, m] + D[m] I <- rbind(x$i, I) N <- x$dimnames if (!is.null(N[[m]])) { N[[m]] <- c( N[[m]], if (!is.null(y$dimnames[[m]])) y$dimnames[[m]] else rep("", y$dim[[m]]) ) if (is.null(names(N))) names(N) <- names(y$dimnames) } else if (!is.null(y$dimnames[[m]])) { if (is.null(N)) N <- y$dimnames else if (is.null(names(N))) names(N) <- names(y$dimnames) N[[m]] <- c( rep("", D[m]), y$dimnames[[m]] ) } D[m] <- D[m] + y$dim[m] x <- simple_sparse_array(I, V, D, N) } x } ### slam/R/rollup.R0000644000175100001440000001513512104226432013066 0ustar hornikusers### rollup <- function(x, MARGIN, INDEX, FUN, ...) UseMethod("rollup") rollup.array <- function(x, MARGIN, INDEX = NULL, FUN = sum, ..., DROP = FALSE) { if (is.character(MARGIN)) MARGIN <- match(MARGIN, names(dimnames(x))) if (!all(match(MARGIN, seq_along(dim(x)), nomatch = 0L))) stop("'MARGIN' invalid") if (is.null(INDEX)) INDEX <- vector("list", length(MARGIN)) else { if (is.atomic(INDEX)) INDEX <- list(INDEX) if (length(INDEX) != length(MARGIN)) stop("'INDEX' invalid length") } names(INDEX) <- MARGIN FUN <- match.fun(FUN) d <- dim(x) n <- dimnames(x) if (is.null(n)) n <- vector("list", length(d)) i <- arrayInd(seq_along(x), .dim = d) for (k in MARGIN) { z <- INDEX[[as.character(k)]] z <- if (is.null(z)) structure( rep(1L, d[k]), levels = "1", class = "factor" ) else { if (length(z) != d[k]) stop(gettextf("INDEX [%s] invalid length", k), domain = NA) factor(z) } i[, k] <- z[i[, k]] z <- levels(z) d[k] <- length(z) n[[k]] <- z rm(z) } i <- .Call(R_vector_index, d, i) i <- structure( i, levels = seq_len(prod(d)), class = "factor" ) i <- split.default(x, i) names(i) <- NULL i <- lapply(i, FUN, ...) if (all(unlist(lapply(i, length)) == 1L)) i <- unlist(i, recursive = FALSE, use.names = FALSE) ## NOTE see drop_simple_sparse_array if (DROP) { if (any(d == 0L)) return(i) k <- which(d == 1L) if (length(k) == length(d)) return(i) if (length(k)) { k <- -k d <- d[k] n <- n[k] } } array(i, d, n) } rollup.matrix <- rollup.array rollup.simple_sparse_array <- function(x, MARGIN, INDEX = NULL, FUN = sum, ..., DROP = FALSE, EXPAND = c("none", "sparse", "dense", "all")) { if (is.character(MARGIN)) MARGIN <- match(MARGIN, names(dimnames(x))) if (!all(match(MARGIN, seq_along(dim(x)), nomatch = 0L))) stop("'MARGIN' invalid") if (is.null(INDEX)) INDEX <- vector("list", length(MARGIN)) else { if (is.atomic(INDEX)) INDEX <- list(INDEX) if (length(INDEX) != length(MARGIN)) stop("'INDEX' invalid length") } names(INDEX) <- MARGIN FUN <- match.fun(FUN) EXPAND <- match( match.arg(EXPAND), eval(formals(rollup.simple_sparse_array)$EXPAND) ) D <- dim(x) I <- x$i if (EXPAND > 1L) { if (EXPAND > 2L) P <- array(1L, dim(I)) T <- vector("list", length(D)) for (k in seq_along(D)[-MARGIN]) T[[k]] <- rep(1L, D[k]) } N <- dimnames(x) if (is.null(N)) N <- vector("list", length(D)) V <- x$v if (EXPAND < 4L && !.Call(R__valid_v, V)) stop("component 'v' contains 'ZERO' value(s)") for (k in MARGIN) { z <- INDEX[[as.character(k)]] z <- if (is.null(z)) structure( rep(1L, D[k]), levels = "1", class = "factor" ) else { if (length(z) != D[k]) stop(gettextf("INDEX [%s] invalid length", k), domain = NA) factor(z) } l <- levels(z) D[k] <- length(l) N[[k]] <- l i <- I[, k] if (EXPAND > 1L) { if (EXPAND > 2L) { p <- .Call(R_part_index, z) T[[k]] <- attr(p, "table") P[, k] <- p[i] rm(p) } else T[[k]] <- tabulate(z, length(l)) } i <- z[i] rm(l, z) I[, k] <- i i <- is.na(i) i <- which(i) if (length(i)) { i <- - i I <- I[i,, drop = FALSE] V <- V[i] if (EXPAND > 2L) P <- P[i,, drop = FALSE] } rm(i) } if (EXPAND == 4L) { ## NOTE see src/main/unique.c in the R ## source code. k <- prod(D) if (k > 1073741824L) stop("number of cells %d too large for hashing", k) i <- .Call(R_vector_index, D, I) I <- arrayInd(seq_len(k), .dim = D) k <- .Call(R_vector_index, D, I) i <- match(i, k) rm(k) } else { i <- .Call(R_match_matrix, I, NULL, NULL) I <- I[i[[2L]],, drop = FALSE] i <- i[[1L]] } i <- structure( i, levels = seq_len(dim(I)[1L]), class = "factor" ) if (EXPAND == 1L) { V <- split.default(V, i) rm(i) names(V) <- NULL V <- lapply(V, FUN, ...) } else { .pt <- proc.time() message(gettextf("processing %d cells ... ", dim(I)[1L]), appendLF = FALSE, domain = NA) i <- split.default(seq_along(i), i) names(i) <- NULL V <- mapply(function(i, z) { z <- I[z, ] z <- mapply("[", T, z) if (EXPAND > 2L) { ## NOTE this consumes less computation time ## and memory than ## z <- array(vector(typeof(V),1L), z) ## z[P[i,, drop = FALSE]] <- V[i] z <- .Call(R_ini_array, z, P, V, i) FUN(z, ...) } else FUN(V[i], prod(z) - length(i), ...) }, i, seq_along(i), SIMPLIFY = FALSE, USE.NAMES = FALSE ) rm(i, T) if (EXPAND > 2L) rm(P) message(sprintf("[%.2fs]\n", (proc.time() - .pt)[3L]), appendLF = FALSE, domain = NA) } if (all(unlist(lapply(V, length)) == 1L)) { V <- unlist(V, recursive = FALSE, use.names = FALSE) i <- V == vector(typeof(V), 1L) i <- which(i) if (length(i)) { i <- - i I <- I[i,, drop = FALSE] V <- V[i] } } x <- simple_sparse_array(I, V, D, N) rm(I, V, D, N) if (DROP) x <- drop_simple_sparse_array(x) x } rollup.simple_triplet_matrix <- function(x, MARGIN, INDEX = NULL, FUN = sum, ...) { FUN <- match.fun(FUN) if (!identical(FUN, sum)) { if (!is.null(list(...)$DROP)) stop("'DROP' not supported") x <- rollup.simple_sparse_array(as.simple_sparse_array(x), MARGIN, INDEX, FUN, ... ) return(as.simple_triplet_matrix(x)) } if (is.character(MARGIN)) MARGIN <- match(MARGIN, names(dimnames(x))) if (!all(match(MARGIN, seq_along(dim(x)), nomatch = 0L))) stop("'MARGIN' invalid") if (is.null(INDEX)) INDEX <- vector("list", length(MARGIN)) else { if (is.atomic(INDEX)) INDEX <- list(INDEX) if (length(INDEX) != length(MARGIN)) stop("'INDEX' invalid length") } names(INDEX) <- MARGIN for (k in MARGIN) { x <- switch(k, t(rollup(t(x), 2L, INDEX[as.character(k)], FUN, ...)), { z <- INDEX[[as.character(k)]] z <- if (is.null(z)) structure( rep(1L, dim(x)[k]), levels = "1", class = "factor" ) else { if (length(z) != dim(x)[k]) stop(gettextf("INDEX [%s] invalid length", k), domain = NA) factor(z) } .Call(R_row_tsums, x, z, if (is.null(list(...)$na.rm)) FALSE else as.logical(list(...)$na.rm), FALSE ) } ) } x } ## rollup.default <- function(x, MARGIN, INDEX = NULL, FUN = sum, ..., DROP = FALSE) { if (!length(dim(x))) stop("dim(x) must have a positive length") rollup(as.array(x), MARGIN, INDEX, FUN, ..., DROP = DROP) } ### slam/R/matrix.R0000644000175100001440000006456512262026562013077 0ustar hornikusers## A simple class for sparse (triplet) matrices. ## Mostly intended for being able to take advantage of LP solvers which ## allow for sparse specifictions of (possible rather large) constraint ## matrices. simple_triplet_matrix <- function(i, j, v, nrow = max(i), ncol = max(j), dimnames = NULL) { stm <- list(i = as.integer(i), j = as.integer(j), v = v, nrow = as.integer(nrow), ncol = as.integer(ncol), dimnames = dimnames) class(stm) <- "simple_triplet_matrix" if(!.Call(R__valid_stm, stm)) stop("failed to create a valid 'simple_sparse_matrix' object") stm } as.simple_triplet_matrix <- function(x) UseMethod("as.simple_triplet_matrix") as.simple_triplet_matrix.simple_triplet_matrix <- identity as.simple_triplet_matrix.matrix <- function(x) { x <- unclass(x) if(!prod(dim(x))) return(simple_triplet_matrix(integer(), integer(), c(x), nrow = nrow(x), ncol = ncol(x), dimnames = dimnames(x))) ind <- which(is.na(x) | (x != vector(typeof(x), 1L)), arr.ind = TRUE) dimnames(ind) <- NULL simple_triplet_matrix(ind[, 1L], ind[, 2L], x[ind], nrow = nrow(x), ncol = ncol(x), dimnames = dimnames(x)) } as.simple_triplet_matrix.default <- function(x) as.simple_triplet_matrix(unclass(as.matrix(x))) ## Sparse matrix classes in package 'Matrix'. as.simple_triplet_matrix.dgTMatrix <- function(x) { simple_triplet_matrix(x@i + 1L, x@j + 1L, x@x, x@Dim[1L], x@Dim[2L], x@Dimnames) } as.simple_triplet_matrix.dgCMatrix <- function(x) { nc <- x@Dim[2L] simple_triplet_matrix(x@i + 1L, rep.int(seq_len(nc), diff(x@p)), x@x, x@Dim[1L], nc, x@Dimnames) } as.simple_triplet_matrix.dgRMatrix <- function(x) { nr <- x@Dim[1L] simple_triplet_matrix(rep.int(seq_len(nr), diff(x@p)), x@j + 1L, x@x, nr, x@Dim[2L], x@Dimnames) } ## See Work/Matrix.R for S4 methods for coercing simple triplet matrices ## to Matrix objects. ## Sparse matrix classes in package 'SparseM'. as.simple_triplet_matrix.matrix.coo <- function(x) simple_triplet_matrix(x@ia, x@ja, x@ra, x@dimension[1L], x@dimension[2L]) as.simple_triplet_matrix.matrix.csc <- function(x) { nc <- x@dimension[2L] simple_triplet_matrix(x@ja, rep.int(seq_len(nc), diff(x@ia)), x@ra, x@dimension[1L], nc) } as.simple_triplet_matrix.matrix.csr <- function(x) { nr <- x@dimension[1L] simple_triplet_matrix(rep.int(seq_len(nr), diff(x@ia)), x@ja, x@ra, nr, x@dimension[2L]) } ## Sparse matrix class in package 'spam'. as.simple_triplet_matrix.spam <- function(x) { nr <- x@dimension[1L] simple_triplet_matrix(rep.int(seq_len(nr), diff(x@rowpointers)), x@colindices, x@entries, nr, x@dimension[2L]) } as.matrix.simple_triplet_matrix <- function(x, ...) { nr <- x$nrow nc <- x$ncol y <- matrix(vector(typeof(x$v), nr * nc), nr, nc) y[cbind(x$i, x$j)] <- x$v dimnames(y) <- x$dimnames y } as.array.simple_triplet_matrix <- function(x, ...) as.array(as.matrix.simple_triplet_matrix(x, ...)) as.simple_triplet_matrix.simple_sparse_array <- function(x) { dx <- x$dim if(length(dx) == 1L) { simple_triplet_matrix( i = x$i[, 1L], j = rep.int(1L, nrow(x$i)), v = x$v, nrow = dx, ncol = 1L, dimnames = if (!is.null(x$dimnames)) c(x$dimnames, list(NULL)) else NULL ) } else if(length(dx) == 2L) { simple_triplet_matrix( i = x$i[,1L], j = x$i[,2L], v = x$v, nrow = x$dim[1L], ncol = x$dim[2L], dimnames = x$dimnames ) } else stop("Unsupported number of dimensions") } is.simple_triplet_matrix <- function(x) inherits(x, "simple_triplet_matrix") is.numeric.simple_sparse_array <- is.numeric.simple_triplet_matrix <- function(x) is.numeric(x$v) Math.simple_triplet_matrix <- function(x, ...) { ## Functions in the Math group mapping 0 to 0: funs <- c("abs", "sign", "sqrt", "floor", "ceiling", "trunc", "round", "signif") if(is.na(match(as.character(.Generic), funs))) stop(gettextf("Generic '%s' not defined for \"%s\" objects.", .Generic, .Class), domain = NA) x$v <- get(.Generic)(x$v, ...) x } Ops.simple_triplet_matrix <- function(e1, e2) { ## Currently, we only implement the following (for numeric ## operands): ## * Unary plus and minus. ## ## * Addition, subtraction and multiplication of two compatible ## simple triplet matrices (or operands coercible to these). ## [Division by a simple triplet matrix typically involves ## division by zero and hence is not provided.] ## ## * Multiplication and division of a simple triplet matrix x by a ## number or a vector of length nrow(x) (allowing to conveniently ## scale the rows of a numeric simple triplet matrix). ## ## * Non-equality comparison of a simple triplet matrix with 0. ## ## * Comparisons of the elements of a simple triplet matrix with a ## number. ## ## More could be added (but note that the elements could have ## arbitrary modes). ## Drop zero-valued elements .reduce <- function(x) { ind <- which(!x$v) if(length(ind)) { ind <- -ind x$i <- x$i[ind] x$j <- x$j[ind] x$v <- x$v[ind] } x } op <- as.character(.Generic) if(nargs() == 1L) { if(op == "+") return(e1) if(op == "-") { e1$v <- - e1$v return(e1) } stop(gettextf("Unary '%s' not defined for \"%s\" objects.", .Generic, .Class), domain = NA) } if(!(op %in% c("+", "-", "*", "/", "^", "==", "!=", "<", "<=", ">", ">="))) stop(gettextf("Generic '%s' not defined for \"%s\" objects.", .Generic, .Class), domain = NA) ## Require numeric operands for the arithmetic operators. if(!is.numeric(e1) || !is.numeric(e2)) stop("Not implemented.") if(op %in% c("==", "!=", "<", "<=", ">", ">=")) { if(length(e2) == 1L) { if(is.na(e2)) stop("NA/NaN handling not implemented.") names(e2) <- NULL ind <- if(do.call(.Generic, list(0, e2))) { ## This inverts the sparse storage advantage, and hence ## will typically be inefficient. Need to find the row ## and column positions of the zero entries. m <- matrix(TRUE, e1$nrow, e1$ncol) m[cbind(e1$i, e1$j)] <- FALSE which(m, arr.ind = TRUE) } else integer() e1$v <- do.call(.Generic, list(e1$v, e2)) e1 <- .reduce(e1) if(n <- NROW(ind)) { e1$i <- c(e1$i, ind[, 1L]) e1$j <- c(e1$j, ind[, 2L]) e1$v <- c(e1$v, rep.int(TRUE, n)) } return(e1) } stop("Not implemented.") } if(op == "^") { ## Allow for taking (single) positive exponents. if(is.object(e2) || (length(e2) != 1L) || !is.finite(e2) || (e2 <= 0)) stop("Not implemented.") names(e2) <- NULL e1$v <- e1$v ^ e2 return(e1) } .make_dimnames <- function(e1, e2) { if(is.null(rnms <- rownames(e1))) rnms <- rownames(e2) if(is.null(cnms <- colnames(e1))) cnms <- colnames(e2) if(is.null(rnms) && is.null(cnms)) NULL else { out <- list(rnms, cnms) if(is.null(nms <- names(dimnames(e1)))) nms <- names(dimnames(e2)) names(out) <- nms out } } ## Obviously, the following could be generalized ... if(op == "*") { if(!is.object(e1)) { e3 <- e2 e2 <- e1 e1 <- e3 } if(!is.object(e2)) { if(length(e2) == 1L) { if(!is.finite(e2)) return(as.simple_triplet_matrix(as.matrix(e1) * e2)) names(e2) <- NULL e1$v <- e1$v * e2 if(!e2) e1 <- .reduce(e1) return(e1) } if(length(e2) == e1$nrow) { names(e2) <- NULL pos <- which(!is.finite(e2)) if(length(pos)) { ## replace with dense rows ind <- match(e1$i, pos, nomatch = 0L) == 0L e1$v <- c(e1$v[ind], as.matrix(e1[pos, ])) e1$i <- c(e1$i[ind], rep.int(pos, e1$ncol)) e1$j <- c(e1$j[ind], rep(seq_len(e1$ncol), each = length(pos))) } e1$v <- e1$v * e2[e1$i] if(any(!e2)) e1 <- .reduce(e1) ## Could add something like ## if(is.null(e1$dimnames) && ## !is.null(nms <- names(e2))) { ## e1$dimnames <- list(nms, NULL) ## } ## but then multiplying a matrix and a vector does not ## seem to do this either ... return(e1) } if(is.matrix(e2)) { if(!all(dim(e2) == c(e1$nrow, e1$ncol))) stop("Incompatible dimensions.") pos <- which(!is.finite(e2)) if(length(pos)) { ## add zeros pos <- pos[match(pos, e1$i + (e1$j - 1L) * e1$nrow, nomatch = 0L) == 0L] - 1L if(length(pos)) { e1$v <- c(e1$v, vector(typeof(e1$v), length(pos))) e1$i <- c(e1$i, pos %% e1$nrow + 1L) e1$j <- c(e1$j, pos %/% e1$nrow + 1L) } } e1$v <- e1$v * e2[cbind(e1$i, e1$j)] if (any(!e2)) e1 <- .reduce(e1) e1$dimnames <- .make_dimnames(e1, e2) return(e1) } stop("Not implemented.") } ## This leaves multiplying two simple triplet matrices. e1 <- as.simple_triplet_matrix(e1) e2 <- as.simple_triplet_matrix(e2) ## Check dimensions: currently, no recycling. if(((nr <- e1$nrow) != e2$nrow) || ((nc <- e1$ncol) != e2$ncol)) stop("Incompatible dimensions.") if(length(e1$v) < length(e2$v)) { ## Swap e1 and e2 so that duplicated indices can be found ## more efficiently. e3 <- e1 e1 <- e2 e2 <- e3 } ## Find duplicated indices. pos <- match(paste(e2$i, e2$j, sep = "\r"), paste(e1$i, e1$j, sep = "\r"), nomatch = 0L) ind <- which(pos > 0L) if(!all(is.finite(e1$v)) || !all(is.finite(e2$v))) { ## Augment and reduce e2$i <- c(e2$i[ind], e2$i[-ind], e1$i[-pos]) e2$j <- c(e2$j[ind], e2$j[-ind], e1$j[-pos]) e2$v <- c(e2$v[ind] * e1$v[pos], vector(typeof(e2$v), 1L) * c(e2$v[-ind], e1$v[-pos])) e2$dimnames <- .make_dimnames(e1, e2) return(.reduce(e2)) } else return(simple_triplet_matrix(e2$i[ind], e2$j[ind], e2$v[ind] * e1$v[pos], nr, nc, .make_dimnames(e1, e2))) } ## This is slightly inefficent but special value handling is already ## in place. Note v / 0 = v * 0^(-1) = v * Inf. if(op == "/") { if(!is.object(e2)) return(e1 * e2^(-1)) e2 <- as.matrix(e2) if (!is.object(e1)) return(as.simple_triplet_matrix(e1 * e2^(-1))) return(e1 * e2^(-1)) } ## This leaves adding and subtracting two simple triplet matrices. e1 <- as.simple_triplet_matrix(e1) e2 <- if(op == "+") as.simple_triplet_matrix(e2) else as.simple_triplet_matrix(-e2) ## Check dimensions: currently, no recycling. if((e1$nrow != e2$nrow) || (e1$ncol != e2$ncol)) stop("Incompatible dimensions.") if(length(e1$v) < length(e2$v)) { ## Swap e1 and e2 so that duplicated indices can be found more ## efficiently. e3 <- e1 e1 <- e2 e2 <- e3 } ## Find duplicated indices. pos <- match(paste(e2$i, e2$j, sep = "\r"), paste(e1$i, e1$j, sep = "\r"), nomatch = 0L) ind <- which(pos == 0L) ## Notice 0 + special value = special value. e1$v[pos] <- e1$v[pos] + e2$v[pos > 0L] e1$i <- c(e1$i, e2$i[ind]) e1$j <- c(e1$j, e2$j[ind]) e1$v <- c(e1$v, e2$v[ind]) e1$dimnames <- .make_dimnames(e1, e2) .reduce(e1) } Summary.simple_triplet_matrix <- function(..., na.rm = FALSE) { v <- unlist(lapply(list(...), function(e) { v <- as.simple_triplet_matrix(e)$v if(length(v) < prod(dim(e))) v <- c(v, vector(typeof(v), 1L)) v }), recursive = FALSE) do.call(.Generic, list(v, na.rm = na.rm)) } dim.simple_triplet_matrix <- function(x) c(x$nrow, x$ncol) `dim<-.simple_triplet_matrix` <- function(x, value) { value <- as.integer(value) if((length(value) != 2L) || any(is.na(value))) stop("invalid dim replacement value") nr <- x$nrow nc <- x$ncol if(prod(value) != nr * nc) stop("invalid dim replacement value") pos <- nr * (x$j - 1L) + x$i - 1L nr <- value[1L] nc <- value[2L] x$i <- pos %% nr + 1L x$j <- pos %/% nr + 1L x$nrow <- nr x$ncol <- nc x$dimnames <- NULL x } dimnames.simple_triplet_matrix <- function(x) x$dimnames `dimnames<-.simple_sparse_array` <- `dimnames<-.simple_triplet_matrix` <- function(x, value) { if(!is.null(value)) { ## NOTE that if length(value) < length(dim(x)) we ## have to assume that the dimensions with index ## seq_len(length(value)) are to be set. For ## example, we are called with a list of length ## one if we call dimnames(x)[[1L]] <- value and ## dimnames(x) == NULL (because of [[<-) ## if(!is.list(value) || length(value) > length(dim(x))) stop("Invalid dimnames.") if(!length(value)) value <- NULL else { dnx <- vector("list", length(dim(x))) len <- sapply(value, length) ind <- which(len > 0L) if (any(len[ind] != dim(x)[ind])) stop("Invalid component length.") dnx[ind] <- lapply(value[ind], as.character) if (!is.null(names(value))) { ind <- seq_len(length(value)) names(dnx)[ind] <- names(value) } } } ## See the constructor (above). if(is.null(value)) x$dimnames <- NULL else x$dimnames <- dnx x } `[.simple_triplet_matrix` <- function(x, i, j, drop = FALSE) { ## (Well, we certainly don't drop ...) ## (See e.g. `[.data.frame` for the trickeries of subscript methods: ## e.g., ## x[i = sample.int(nr, k), , drop = FALSE] ## counts 4 arguments (x, i, j and drop) where j is missing ... na <- nargs() - !missing(drop) if((na == 1L) || (na == 2L) && missing(i) || (na == 3L) && missing(i) && missing(j)) return(x) nr <- x$nrow nc <- x$ncol if(na == 2L) { ## Single index subscripting. ## Mimic subscripting matrices: no named argument handling in ## this case. if(is.character(i)) out <- vector(typeof(x$v))[rep.int(NA, length(i))] else if(!is.matrix(i)) { if(is.logical(i)) { if(nr * nc > 16777216L) stop("Logical vector subscripting disabled for this object.") i <- which(rep(i, length.out = nr * nc)) } else if(!is.numeric(i)) stop(gettextf("Invalid subscript type: %s.", typeof(i)), domain = NA) else ## 52-bit safe if(nr * nc > 4503599627370496) stop("Numeric vector subscripting disabled for this object.") ## Shortcut if(!length(i)) return(vector(mode = typeof(x$v), length = 0L)) if(is.double(i)) i <- trunc(i) ## Let's hope we have a vector. ## What if we have both negatives and positives? if(all(i >= 0, na.rm = TRUE)) { i <- i[i > 0] out <- vector(mode = typeof(x$v), length = length(i)) if(length(out)) { is.na(i) <- i > nr * nc is.na(out) <- is.na(i) i <- match(i, (x$j - 1L) * nr + x$i, 0L) out[i > 0L] <- x$v[i] } } else if(!any(is.na(i)) && all(i <= 0)) { if(nr * nc > 16777216L) stop("Negative vector subscripting disabled for this object.") out <- vector(mode = typeof(x$v), nr * nc) out[(x$j - 1L) * nr + x$i] <- x$v out <- out[i] } else stop("Cannot mix positive and negative subscripts.") } else { ## Shortcut if(!nrow(i)) return(vector(mode = typeof(x$v), length = 0L)) ## Ignore dimensions if(ncol(i) != 2L) return(do.call("[.simple_triplet_matrix", list(x = x, as.vector(i)))) ## Note that negative values are not allowed in a matrix ## subscript. if(is.double(i)) i <- trunc(i) if(any(i < 0, na.rm = TRUE)) stop("Invalid subscript.") ## Rows containing zero indices can be dropped. ## Rows with NA indices should give NA (at least for ## non-recursive x). k <- .Call(R_all_row, i > 0, FALSE) i <- i[k, ,drop = FALSE] out <- vector(mode = typeof(x$v), length = nrow(i)) if(length(out)) { if (any(i > rep(c(nr, nc), each = nrow(i)), na.rm = TRUE)) stop("subscript out of bounds") k <- k[k] is.na(out) <- is.na(k) rm(k) ## See duplicated.matrix ## pos <- match(paste(i[, 1L], i[, 2L], sep = "\r"), ## paste(x$i, x$j, sep = "\r"), ## nomatch = 0L) storage.mode(i) <- "integer" i <- .Call(R_match_matrix, cbind(x$i, x$j), i, 0L)[[2L]] out[i > 0L] <- x$v[i] } } } else { ## Two index subscripting is rather tricky, as it can also be ## used for rearranging and "recycling" rows and columns. Let ## us not support the latter for now, so that selected rows and ## columns must be unique. pos <- NULL if(!missing(i)) { if(any(is.na(i))) stop("NA indices not allowed.") pi <- seq_len(nr) if(is.logical(i)) { i <- rep(i, length.out = nr) nr <- sum(i) pos <- i[x$i] } else { if(is.character(i)) { i <- match(i, rownames(x)) if(any(is.na(i))) stop("Subscript out of bounds.") if(any(duplicated(i))) stop("Repeated indices currently not allowed.") } else if(is.numeric(i)) { if(is.double(i)) i <- trunc(i) if(all(i >= 0)) { i <- i[i > 0] if(any(i > nr)) stop("subscript out of bounds") if(any(duplicated(i))) stop("Repeated indices currently not allowed.") } else if(all(i <= 0)) i <- pi[i] else stop("Cannot mix positive and negative subscripts.") } else { stop(gettextf("Invalid subscript type: %s.", typeof(i)), domain = NA) } nr <- length(i) pos <- match(x$i, i, 0L) > 0L } pi[i] <- seq_len(nr) } if(!missing(j)) { if(any(is.na(j))) stop("NA indices not allowed.") pj <- seq_len(nc) if(is.logical(j)) { j <- rep(j, length.out = nc) nc <- sum(j) pos <- if(is.null(pos)) j[x$j] else j[x$j] & pos } else { if(is.character(j)) { j <- match(j, colnames(x)) if(any(is.na(j))) stop("Subscript out of bounds.") if(any(duplicated(j))) stop("Repeated indices currently not allowed.") } else if(is.numeric(j)) { if(is.double(j)) j <- trunc(j) if(all(j >= 0)) { j <- j[j > 0] if(any(j > nc)) stop("subscript out of bounds") if(any(duplicated(j))) stop("Repeated indices currently not allowed.") } else if(all(j <= 0)) j <- pj[j] else stop("Cannot mix positive and negative subscripts.") } else { stop(gettextf("Invalid subscript type: %s.", typeof(j)), domain = NA) } nc <- length(j) pos <- if(is.null(pos)) (match(x$j, j, 0L) > 0L) else (match(x$j, j, 0L) > 0L) & pos } pj[j] <- seq_len(nc) } if(!is.null(dnx <- x$dimnames)) { if (!missing(i)) { dnx[1L] <- list(dnx[[1L]][i]) if (!length(dnx[[1L]])) dnx[1L] <- list(NULL) } if (!missing(j)) { dnx[2L] <- list(dnx[[2L]][j]) if (!length(dnx[[2L]])) dnx[2L] <- list(NULL) } if (!length(dnx[[1L]]) && !length(dnx[[2L]])) dnx <- NULL } i <- if(missing(i)) x$i[pos] else pi[x$i[pos]] j <- if(missing(j)) x$j[pos] else pj[x$j[pos]] out <- simple_triplet_matrix(i, j, x$v[pos], nr, nc, dnx) } out } rbind.simple_triplet_matrix <- function(..., deparse.level = 1L) { args <- lapply(Filter(Negate(is.null), list(...)), as.simple_triplet_matrix) ## Ignore 'deparse.level' ... out <- Reduce(function(x, y) { if((nc <- ncol(x)) != ncol(y)) stop("Numbers of columns of matrices must match.") nr <- nrow(x) simple_triplet_matrix(c(x$i, y$i + nr), c(x$j, y$j), c(x$v, y$v), nrow = nr + nrow(y), ncol = nc) }, args) ## Handle dimnames in one final step. rnms <- lapply(args, rownames) rnms <- if(!all(sapply(rnms, is.null))) { rnms <- mapply(function(rnm, n) if(is.null(rnm)) rep.int("", n) else rnm, rnms, lapply(args, nrow), SIMPLIFY = FALSE ) do.call("c", rnms) } else NULL cnms <- Find(Negate(is.null), lapply(args, colnames)) dimnames(out) <- list(rnms, cnms) out } cbind.simple_triplet_matrix <- function(..., deparse.level = 1L) { args <- lapply(Filter(Negate(is.null), list(...)), as.simple_triplet_matrix) ## Ignore 'deparse.level' ... out <- Reduce(function(x, y) { if((nr <- nrow(x)) != nrow(y)) stop("Numbers of rows of matrices must match.") nc <- ncol(x) simple_triplet_matrix(c(x$i, y$i), c(x$j, y$j + nc), c(x$v, y$v), nrow = nr, ncol = nc + ncol(y)) }, args) ## Handle dimnames in one final step. cnms <- lapply(args, colnames) cnms <- if(!all(sapply(cnms, is.null))) { cnms <- mapply(function(cnm, n) if(is.null(cnm)) rep.int("", n) else cnm, cnms, lapply(args, ncol), SIMPLIFY = FALSE ) do.call("c", cnms) } else NULL rnms <- Find(Negate(is.null), lapply(args, rownames)) dimnames(out) <- list(rnms, cnms) out } t.simple_triplet_matrix <- function(x) simple_triplet_matrix(x$j, x$i, x$v, x$ncol, x$nrow, rev(x$dimnames)) duplicated.simple_triplet_matrix <- function(x, incomparables = FALSE, MARGIN = 1L, fromLast = FALSE, ...) { ## We could use the duplicated method for class matrix, but at the ## expense of going from sparse to dense ... if(!is.logical(incomparables) || incomparables) .NotYetUsed("incomparables != FALSE") if(MARGIN == 1L) { i <- x$i j <- x$j len <- x$nrow } else if(MARGIN == 2L) { i <- x$j j <- x$i len <- x$ncol } else stop("Invalid margin.") o <- order(i, j) y <- split(paste(j[o], x$v[o], sep = "\r"), i[o]) tmp <- character(len) names(tmp) <- seq_along(tmp) tmp[names(y)] <- sapply(y, paste, collapse = "\r") duplicated(tmp, fromLast = fromLast) } unique.simple_triplet_matrix <- function(x, incomparables = FALSE, MARGIN = 1L, fromLast = FALSE, ...) { if(!is.logical(incomparables) || incomparables) .NotYetUsed("incomparables != FALSE") ind <- !duplicated(x, MARGIN = MARGIN, fromLast = fromLast) if(MARGIN == 1L) x[which(ind), ] else x[, which(ind)] } c.simple_triplet_matrix <- function(..., recursive = FALSE) { args <- list(...) ind <- which(sapply(args, inherits, "simple_triplet_matrix")) args[ind] <- lapply(args[ind], function(x) { y <- vector(typeof(x$v), x$nrow * x$ncol) y[x$i + (x$j - 1L) * x$nrow] <- x$v y }) do.call("c", args) } print.simple_triplet_matrix <- function(x, ...) { writeLines(gettextf("A %s simple triplet matrix.", paste(dim(x), collapse = "x"))) invisible(x) } mean.simple_triplet_matrix <- function(x, ...) { sum(x$v) / prod(dim(x)) } aperm.simple_triplet_matrix <- function(a, perm = NULL, ...) { s <- c(1L, 2L) if(!is.null(perm)) { perm <- if(is.character(perm)) match(perm, names(a$dimnames)) else if(is.numeric(perm)) match(perm, s) else NULL if(length(perm) != length(s) || any(is.na(perm))) stop("Invalid permutation.") if(all(perm == s)) return(a) } ## Transpose. t.simple_triplet_matrix(a) } as.vector.simple_triplet_matrix <- function(x, mode = "any") as.vector(as.matrix(x), mode) ## Utilities for creating special simple triplet matrices: simple_triplet_zero_matrix <- function(nrow, ncol = nrow, mode = "double") simple_triplet_matrix(integer(), integer(), vector(mode, 0L), nrow, ncol) simple_triplet_diag_matrix <- function(v, nrow = length(v)) { v <- rep(v, length.out = nrow) i <- seq_len(nrow) simple_triplet_matrix(i, i, v, nrow, nrow) } slam/MD50000644000175100001440000000610212316730752011541 0ustar hornikusers2a39ca4e715e80d34c89842a14c12fcc *DESCRIPTION f56b06f385a4253280d909f000a1c1f1 *NAMESPACE 6da5f4bb978d5d2ab7de8ddd6c977571 *R/abind.R b94f005638ee208bb4417ccb4893aa68 *R/apply.R bae6cb5d24e86d83d09c93a0c15fd103 *R/array.R 41e489be2096cfeb9698676b24c5cd99 *R/crossprod.R c4c13f3dd3aa408f21c3588a110790ac *R/foreign.R 8b23c23f52157e14b29403bb1cd3ab11 *R/matrix.R dd2ab1bd69bd82fa36c13b5832354e9c *R/reduce.R b3b8a760dce607548a5b0199751acdcf *R/rollup.R 081170556760537396d1c76b108027f2 *R/stm.R 9f47c841773753b7d83c09d6daeb461d *R/subassign.R 21736500a7b5530d1c2d5e75faee4c35 *man/abind.Rd b549d8099a6034335d09c825532c0fca *man/apply.Rd 1237aa6694b85fba24fdf173a09adb3b *man/array.Rd 57ab89e1ab8f7af331b824054f9a22a0 *man/crossprod.Rd 70074ed00c0a76ffec8f177b7c8264ca *man/foreign.Rd 2e276d68899202ed1793e18793a53a50 *man/matrix.Rd c654d2bd652ea6876766d95d6d8e8ca5 *man/norms.Rd 833e72b8fbf64075a6c9bf5f082205e1 *man/rollup.Rd f75048a25feebac938f74e1ed79fe683 *man/sums.Rd 2fa4c7011c2bc0f7449ae151d5cc44ae *src/Makevars dc088b0ac562f358ced61cdedbbf757d *src/apply.c 9073b9f0973185bf58235f4c640f21e7 *src/grouped.c 63ba179c0961b98315f55b2cf0fd359b *src/sparse.c f404802b0bc9fbc1c7062fabcacbcdfa *src/util.c 6e9231824027888adde90f5b525bed48 *tests/abind.R 2a747ac2d11d058340e8f0c8bc01d71e *tests/abind.Rout.save 9d8026ba97ffb2ae9da0d60bfec7cbab *tests/apply.R 8f7e0558465a3d7bc38c914a3bc08997 *tests/apply.Rout.save 0163073a0b1bc0d95defebb7bbeebcdd *tests/crossprod.R 50af4aa7903c8644aa566f8fa887ecdb *tests/crossprod.Rout.save bc27d868d522803f1ea436592cbc98f1 *tests/dimgets.R cc0d735778fd4f47d9676e4b6ed60212 *tests/extract.R 7d812592cd7ee9645b40d332165f3507 *tests/extract.Rout.save a3f7839ed3a231dc02f704df7333ba70 *tests/matrix.R b86c28c833275f95a0640bda242e0cbb *tests/matrix.Rout.save 1aedaf99201b77a1074e9118bc5704d2 *tests/matrix_dimnames.R 0a73c3fcb1cf31632db30941809f2b1d *tests/matrix_dimnames.Rout.save f0982dad0cd3b3b4be0ba3b4c6c6ad2a *tests/rollup.R 88b56aa248dca90739fdeb1133164e5d *tests/rollup.Rout.save 46fd1f36f27c217c9840e0de65dcc4ad *tests/ssa_valid.R 643da57c362b62fa828dbf402b42ac9d *tests/ssa_valid.Rout.save c9b9eb21094294bd1a5df45a757c7961 *tests/stm.R 66f2102d9e82b5dd878399b7c19eaef8 *tests/stm.Rout.save c08e0dd2853dd24d35c71fb05b0c3998 *tests/stm_apply.R 6d6c5b37fc83131692759b25f3b0dd75 *tests/stm_apply.Rout.save 6ffa919f62a5c8c3679ba01c6ee8c245 *tests/stm_rollup.R 13e4b2e3958e243f5e5f800504e23754 *tests/stm_rollup.Rout.save 0a44fc6c35f124d6e97e973abeddec5e *tests/stm_subassign.R b3f5ab7d9d4821c0ba990baf4f617749 *tests/stm_subassign.Rout.save 3c189e5d8a81829b28d4d548dfc143df *tests/stm_ttcrossprod.R 935594f3f4913951dcc6e0c23301f3a1 *tests/stm_ttcrossprod.Rout.save 1f6250d61d1f2829414b4584df18050f *tests/stm_valid.R 1b56e8328e82d2b2766eae2061d8b460 *tests/stm_valid.Rout.save d6b3420aa02e332ae1642bea3accce10 *tests/stm_zeros.R c88b4e2f403e1a8f3ba07fadcc73c7e4 *tests/stm_zeros.Rout.save 1de2d8f2c87f9310d610bca4723a6960 *tests/subassign.R 74f90d3fb160859744e5e9f4f33ef091 *tests/subassign.Rout.save 6d0876bf6323e5b96be806e62876a011 *tests/util.R ffc8148a014f55ce7602d4d476c0e5fb *tests/util.Rout.save slam/DESCRIPTION0000644000175100001440000000142712316730752012744 0ustar hornikusersPackage: slam Version: 0.1-32 Title: Sparse Lightweight Arrays and Matrices Authors@R: c(person("Kurt", "Hornik", role = c("aut", "cre"), email = "Kurt.Hornik@R-project.org"), person("David", "Meyer", role = "aut"), person("Christian", "Buchta", role = "aut")) Description: Data structures and algorithms for sparse arrays and matrices, based on index arrays and simple triplet representations, respectively. Depends: R (>= 2.8.0) Imports: stats Enhances: Matrix, SparseM, spam License: GPL-2 Packaged: 2014-04-01 17:52:46 UTC; hornik Author: Kurt Hornik [aut, cre], David Meyer [aut], Christian Buchta [aut] Maintainer: Kurt Hornik NeedsCompilation: yes Repository: CRAN Date/Publication: 2014-04-02 08:44:58 slam/man/0000755000175100001440000000000012262026562012002 5ustar hornikusersslam/man/foreign.Rd0000644000175100001440000000431712252571564013735 0ustar hornikusers\name{foreign} \alias{read_stm_CLUTO} \alias{write_stm_CLUTO} \alias{read_stm_MC} \alias{write_stm_MC} \title{Read and Write Sparse Matrix Format Files} \description{ Read and write CLUTO sparse matrix format files, or the CCS format variant employed by the MC toolkit. } \usage{ read_stm_CLUTO(file) write_stm_CLUTO(x, file) read_stm_MC(file, scalingtype = NULL) write_stm_MC(x, file) } \arguments{ \item{file}{a character string with the name of the file to read or write.} \item{x}{a matrix object.} \item{scalingtype}{a character string specifying the type of scaling to be used, or \code{NULL} (default), in which case the scaling will be inferred from the names of the files with non-zero entries found (see \bold{Details}). } } \details{ Documentation for CLUTO including its sparse matrix format is available from \url{http://www-users.cs.umn.edu/~karypis/cluto/}. \code{read_stm_CLUTO} reads CLUTO sparse matrices, returning a \link[slam:matrix]{simple triplet matrix}. \code{write_stm_CLUTO} writes CLUTO sparse matrices. Argument \code{x} must be coercible to a simple triplet matrix via \code{\link[slam:matrix]{as.simple_triplet_matrix}}. MC is a toolkit for creating vector models from text documents (see \url{http://www.cs.utexas.edu/users/dml/software/mc/}). It employs a variant of Compressed Column Storage (CCS) sparse matrix format, writing data into several files with suitable names: e.g., a file with \file{_dim} appended to the base file name stores the matrix dimensions. The non-zero entries are stored in a file the name of which indicates the scaling type used: e.g., \file{_tfx_nz} indicates scaling by term frequency (\samp{t}), inverse document frequency (\samp{f}) and no normalization (\samp{x}). See \file{README} in the MC sources for more information. \code{read_stm_MC} reads such sparse matrix information with argument \code{file} giving the path with the base file name, and returns a \link[slam:matrix]{simple triplet matrix}. \code{write_stm_MC} writes matrices in MC CCS sparse matrix format. Argument \code{x} must be coercible to a simple triplet matrix via \code{\link[slam:matrix]{as.simple_triplet_matrix}}. } \keyword{IO} slam/man/matrix.Rd0000644000175100001440000000516112116170732013575 0ustar hornikusers\name{simple_triplet_matrix} \alias{simple_triplet_matrix} \alias{simple_triplet_zero_matrix} \alias{simple_triplet_diag_matrix} \alias{as.simple_triplet_matrix} \alias{is.simple_triplet_matrix} \title{Simple Triplet Matrix} \description{Data structures and operators for sparse matrices based on simple triplet representation.} \usage{ simple_triplet_matrix(i, j, v, nrow = max(i), ncol = max(j), dimnames = NULL) simple_triplet_zero_matrix(nrow, ncol = nrow, mode = "double") simple_triplet_diag_matrix(v, nrow = length(v)) as.simple_triplet_matrix(x) is.simple_triplet_matrix(x) } \arguments{ \item{i, j}{Integer vectors of row and column indices, respectively.} \item{v}{Vector of values.} \item{nrow, ncol}{Integer values specifying the number of rows and columns, respectively. Defaults are the maximum row and column indices, respectively.} \item{dimnames}{A \code{dimnames} attribute for the matrix: \code{NULL} or a \code{list} of length 2 giving the row and column names respectively. An empty list is treated as \code{NULL}, and a list of length one as row names. The list can be named, and the list names will be used as names for the dimensions.} \item{mode}{Character string specifying the mode of the values.} \item{x}{An \R object.} } \details{ \code{simple_triplet_matrix} is a generator for a class of \dQuote{lightweight} sparse matrices, \dQuote{simply} represented by triplets \code{(i, j, v)} of row indices \code{i}, column indices \code{j}, and values \code{v}, respectively. \code{simple_triplet_zero_matrix} and \code{simple_triplet_diag_matrix} are convenience functions for the creation of empty and diagonal matrices. Currently implemented operations include the addition, subtraction, multiplication and division of compatible simple triplet matrices, as well as the multiplication and division of a simple triplet matrix and a vector. Comparisons of the elements of a simple triplet matrices with a number are also provided. In addition, methods for indexing, combining by rows (\code{rbind}) and columns (\code{cbind}), transposing (\code{t}), concatenating (\code{c}), and detecting/extracting duplicated and unique rows are implemented. } \seealso{ \code{\link{simple_sparse_array}} for sparse arrays. } \examples{ x <- matrix(c(1, 0, 0, 2), nrow = 2) s <- as.simple_triplet_matrix(x) identical(x, as.matrix(s)) simple_triplet_matrix(c(1, 4), c(1, 2), c(1, 2)) simple_triplet_zero_matrix(3) simple_triplet_diag_matrix(1:3) cbind(rbind(x, t(x)), rbind(x, x)) } \keyword{math} slam/man/norms.Rd0000644000175100001440000000104012220373656013425 0ustar hornikusers\name{norms} \alias{row_norms} \alias{col_norms} \title{Row and Column Norms} \description{ Compute row and column \eqn{p}-norms. } \usage{ row_norms(x, p = 2) col_norms(x, p = 2) } \arguments{ \item{x}{a sparse \code{\link{simple_triplet_matrix}}, or a dense matrix.} \item{p}{a numeric at least one. Using \code{Inf} gives the maximum norm.} } \value{ A vector with the row or column \eqn{p}-norms for the given matrix. } \examples{ x <- matrix(1 : 9, 3L) ## Row lengths: row_norms(x) ## Column maxima: col_norms(x, Inf) } slam/man/array.Rd0000644000175100001440000000623512032102630013377 0ustar hornikusers\name{simple_sparse_array} \alias{simple_sparse_array} \alias{simple_sparse_zero_array} \alias{as.simple_sparse_array} \alias{is.simple_sparse_array} \alias{simplify_simple_sparse_array} \alias{reduce_simple_sparse_array} \alias{drop_simple_sparse_array} \title{Simple Sparse Arrays} \description{Data structures and operators for sparse arrays based on a representation by index matrix and value vector.} \usage{ simple_sparse_array(i, v, dim = NULL, dimnames = NULL) as.simple_sparse_array(x) is.simple_sparse_array(x) simplify_simple_sparse_array(x, higher = TRUE) reduce_simple_sparse_array(x, strict = FALSE, order = FALSE) drop_simple_sparse_array(x) } \arguments{ \item{i}{Integer matrix of array indices.} \item{v}{Vector of values.} \item{dim}{Integer vector specifying the size of the dimensions.} \item{dimnames}{either \code{NULL} or the names for the dimensions. This is a list with one component for each dimension, either \code{NULL} or a character vector of the length given by \code{dim} for that dimension. The list can be named, and the list names will be used as names for the dimensions. If the list is shorter than the number of dimensions, it is extended by \code{NULL}'s to the length required.} \item{x}{An \R object; an object of class \code{simple_sparse_array} (see Note).} \item{higher}{Option to use the dimensions of the values (see Note).} \item{strict}{Option to treat violations of sparse representation as error (see Note).} \item{order}{Option to reorder elements (see Note).} } \details{ \code{simple_sparse_array} is a generator for a class of \dQuote{lightweight} sparse arrays, represented by index matrices and value vectors. Currently, only methods for indexing and coercion are implemented. } \note{ The \emph{zero} element is defined as \code{vector(typeof(v), 1L)}, for example, \code{FALSE} for \code{logical} values (see \code{\link{vector}}). Clearly, sparse arrays should not contain \emph{zero} elements, however, for performance reasons the class generator does not remove them. If \code{strict = FALSE} (default) \code{reduce_simple_sparse_array} tries to repair violations of sparse representation (\emph{zero, multiple} elements), otherwise it stops. If \code{order = TRUE} the elements are further reordered (see \code{\link{array}}). \code{simplify_simple_sparse_array} tries to reduce \code{v}. If \code{higher = TRUE} (default) augments \code{x} by the common dimensions of \code{v} (from the left), or the common length. Note that \emph{scalar} elements are never extended and unused dimensions never dropped. \code{drop_simple_sparse_array} drops unused dimensions. If \code{prod(dim(x)) > 2^24} empty and negative indexing are disabled for \code{[} and \code{[<-}. Further, non-negative single (vector) indexing is limited to 52 bits of representation. } \seealso{ \code{\link{simple_triplet_matrix}} for sparse matrices. } \examples{ x <- array(c(1, 0, 0, 2, 0, 0, 0, 3), dim = c(2, 2, 2)) s <- as.simple_sparse_array(x) identical(x, as.array(s)) simple_sparse_array(matrix(c(1, 3, 1, 3, 1, 3), nrow = 2), c(1, 2)) } \keyword{math} slam/man/abind.Rd0000644000175100001440000000356211753474631013364 0ustar hornikusers\name{abind} \alias{abind_simple_sparse_array} \alias{extend_simple_sparse_array} \title{Combine Sparse Arrays} \description{Combine a sequence of (sparse) arrays, matrices, or vectors into a single sparse array of the same or higher dimension.} \usage{ abind_simple_sparse_array(..., MARGIN = 1L) extend_simple_sparse_array(x, MARGIN = 0L) } \arguments{ \item{\dots}{\R objects of (or coercible to) class \code{simple_sparse_array}.} \item{MARGIN}{The dimension along which to bind the arrays.} \item{x}{An object of class \code{simple_sparse_array}.} } \details{ \code{abind_simple_sparse_array} automatically extends the dimensions of the elements of \sQuote{\dots} before it combines them along the dimension specified in \code{MARGIN}. If a negative value is specified first all elements are extended left of the target dimension. \code{extend_simple_sparse_array} inserts one (or more) one-level dimension(s) into \code{x} to the right of the position(s) specified in \code{MARGIN}, or to the left if specified in negative terms. Note that the target positions must all be in the range of the dimensions of \code{x} (see Examples). } \value{ An object of class \code{simple_sparse_array} where the \code{dimnames} are taken from the elements of \sQuote{\dots}. } \author{ Christian Buchta } \seealso{ \code{\link{simple_sparse_array}} for sparse arrays. } \examples{ ## automatic abind_simple_sparse_array(1:3, array(4:6, c(1,3))) abind_simple_sparse_array(1:3, array(4:6, c(3,1)), MARGIN = 2L) ## manual abind_simple_sparse_array(1:3, 4:6) abind_simple_sparse_array(1:3, 4:6, MARGIN = -2L) ## by columns abind_simple_sparse_array(1:3, 4:6, MARGIN = -1L) ## by rows ## a <- as.simple_sparse_array(1:3) a extend_simple_sparse_array(a, c( 0L, 1L)) extend_simple_sparse_array(a, c(-1L,-2L)) ## the same extend_simple_sparse_array(a, c( 1L, 1L)) } \keyword{array} slam/man/apply.Rd0000644000175100001440000000367412262026562013430 0ustar hornikusers\name{apply} \alias{rowapply_simple_triplet_matrix} \alias{colapply_simple_triplet_matrix} \alias{crossapply_simple_triplet_matrix} \alias{tcrossapply_simple_triplet_matrix} \title{ Apply Functions Over Sparse Matrix Margins } \description{ Apply functions to (the cross-pairs of) the rows or columns of a sparse matrix. } \usage{ rowapply_simple_triplet_matrix(x, FUN, ...) colapply_simple_triplet_matrix(x, FUN, ...) crossapply_simple_triplet_matrix(x, y = NULL, FUN, ...) tcrossapply_simple_triplet_matrix(x, y = NULL, FUN, ...) } \arguments{ \item{x, y}{a matrix in \code{simple_triplet_matrix}-form or, one of \code{x} and \code{y}, of class \code{matrix}. } \item{FUN}{the name of the function to be applied. } \item{\dots}{optional arguments to \code{FUN}. } } \details{ \code{colapply_simple_triplet_matrix} temporarily expands each column of \code{x} to dense \code{vector} representation and applies the function specified in \code{FUN}. \code{crossapply_simple_triplet_matrix} temporarily expands each cross-pair of columns of \code{x} (and \code{y}) to dense \code{vector} representation and applies the function specified in \code{FUN}. Note that if \code{y = NULL} then only the entries in the lower triangle and the diagonal are computed, assuming that \code{FUN} is symmetric. } \value{ A \code{vector} (\code{matrix}) of length (dimensionality) of the margin(s) used. The type depends on the result of \code{FUN}. Note that the result of \code{colapply_simple_triplet_matrix} is never simplified to \code{matrix}. } \author{ Christian Buchta } %\note{ %} \seealso{ \code{\link[base]{apply}} for dense-on-dense computations. } \examples{ ## x <- matrix(c(1, 0, 0, 2, 1, 0), nrow = 3, dimnames = list(1:3, LETTERS[1:2])) x s <- as.simple_triplet_matrix(x) colapply_simple_triplet_matrix(s, FUN = var) ## simplify2array(colapply_simple_triplet_matrix(s, identity)) ## crossapply_simple_triplet_matrix(s, FUN = var) } \keyword{algebra} \keyword{array} slam/man/sums.Rd0000644000175100001440000000365111314343030013252 0ustar hornikusers\name{sums} % NOTE need generics \alias{row_sums} \alias{row_sums.simple_triplet_matrix} \alias{col_sums} \alias{col_sums.simple_triplet_matrix} \alias{row_means} \alias{row_means.simple_triplet_matrix} \alias{col_means} \alias{col_means.simple_triplet_matrix} \title{ Form Row and Column Sums and Means } \description{ Form row and column sums and means for sparse arrays (currently \code{simple_triplet_matrix} only). } \usage{ row_sums(x, na.rm = FALSE, dims = 1, \dots) col_sums(x, na.rm = FALSE, dims = 1, \dots) row_means(x, na.rm = FALSE, dims = 1, \dots) col_means(x, na.rm = FALSE, dims = 1, \dots) \method{row_sums}{simple_triplet_matrix}(x, na.rm = FALSE, dims = 1, \dots) \method{col_sums}{simple_triplet_matrix}(x, na.rm = FALSE, dims = 1, \dots) \method{row_means}{simple_triplet_matrix}(x, na.rm = FALSE, dims = 1, \dots) \method{col_means}{simple_triplet_matrix}(x, na.rm = FALSE, dims = 1, \dots) } \arguments{ \item{x}{a sparse array containing numeric, integer, or logical values. } \item{na.rm}{logical. Should missing values (including \code{NaN}) be omitted from the calculations? } \item{dims}{currently not used for sparse arrays. } \item{\dots}{currently not used for sparse arrays. } } \details{ Provides fast summation over the rows or columns of sparse matrices in \code{simple_triplet}-form. } \value{ A numeric (double) array of suitable size, or a vector if the result is one-dimensional. The \code{dimnames} (or \code{names} for a vector result) are taken from the original array. } \author{ Christian Buchta } \note{ Results are always of storage type \code{double} to avoid (integer) overflows. } \seealso{ \code{simple_triplet_matrix}, \code{\link[base]{colSums}} for dense numeric arrays. } \examples{ ## x <- matrix(c(1, 0, 0, 2, 1, NA), nrow = 3) x s <- as.simple_triplet_matrix(x) row_sums(s) row_sums(s, na.rm = TRUE) col_sums(s) col_sums(s, na.rm = TRUE) } \keyword{array} \keyword{algebra} \keyword{arith} slam/man/crossprod.Rd0000644000175100001440000000256412254246630014317 0ustar hornikusers\name{crossprod} \alias{tcrossprod_simple_triplet_matrix} \alias{crossprod_simple_triplet_matrix} \alias{matprod_simple_triplet_matrix} \title{ Matrix Crossproduct } \description{ Compute the matrix cross-product of a sparse and a dense or sparse matrix. } \usage{ tcrossprod_simple_triplet_matrix(x, y = NULL) ## crossprod_simple_triplet_matrix(x, y = NULL) matprod_simple_triplet_matrix(x, y) } \arguments{ \item{x, y}{a matrix in \code{simple_triplet_matrix}-form and/or a dense matrix, where one must be of the form indicated by the suffix. } } \details{ Function \code{tcrossprod_simple_triplet_matrix} implements fast computation of \code{x \%*\% t(x)} and \code{x \%*\% t(y)} (\code{tcrossprod}). The remaining functions are (optimized) wrappers. } \value{ A double matrix, with appropriate \code{dimnames} taken from \code{x} and \code{y}. } \author{ Christian Buchta } \note{ The computation is delegated to \code{tcrossprod} if \code{y} (or \code{x} if \code{y == NULL}) contains any of the special values \code{NA}, \code{NaN}, or \code{Inf}. } \seealso{ \code{\link[base]{crossprod}} for dense-on-dense computations. } \examples{ ## x <- matrix(c(1, 0, 0, 2, 1, 0), nrow = 3) x s <- as.simple_triplet_matrix(x) tcrossprod_simple_triplet_matrix(s, x) ## tcrossprod_simple_triplet_matrix(s) ## tcrossprod_simple_triplet_matrix(s[1L, ], s[2:3, ]) } \keyword{algebra} \keyword{array} slam/man/rollup.Rd0000644000175100001440000000650711746150514013617 0ustar hornikusers\name{rollup} % NOTE need generics \alias{rollup} \alias{rollup.array} \alias{rollup.matrix} \alias{rollup.simple_triplet_matrix} \alias{rollup.simple_sparse_array} \title{ Rollup Sparse Arrays } \description{ Rollup (aggregate) sparse arrays along arbitrary dimensions. } \usage{ rollup(x, MARGIN, INDEX, FUN, ...) \method{rollup}{simple_triplet_matrix}(x, MARGIN, INDEX = NULL, FUN = sum, \dots) \method{rollup}{simple_sparse_array}(x, MARGIN, INDEX = NULL, FUN = sum, \dots, DROP = FALSE, EXPAND = c("none", "sparse", "dense", "all")) \method{rollup}{matrix}(x, MARGIN, INDEX = NULL, FUN = sum, \dots, DROP = FALSE) \method{rollup}{array}(x, MARGIN, INDEX = NULL, FUN = sum, \dots, DROP = FALSE) } \arguments{ \item{x}{a sparse (or dense) array, typically of numeric or logical values. } \item{MARGIN}{a vector giving the subscripts (names) of the dimensions to be rolled up. } \item{INDEX}{a corresponding (\code{list} of) \code{factor} (components) in the sense that \code{as.factor} defines the grouping(s). If \code{NULL} collapses the corresponding dimension(s) (default).} \item{FUN}{the name of the function to be applied. } \item{DROP}{option to delete the dimensions of the result which have only one level.} \item{EXPAND}{the cell expansion method to use (see Details). } \item{\dots}{optional arguments to \code{FUN}. } } \details{ Provides fast summation over the rows or columns of sparse matrices in \code{simple_triplet}-form. If (a component of) \code{INDEX} contains \code{NA} values the corresponding parts of \code{x} are omitted. For \code{simple_sparse_array} the following cell expansion methods are provided: \describe{ \item{\code{none}:}{The \emph{non-zero} entries of a cell, if any, are supplied to \code{FUN} as a \code{vector}.} \item{\code{sparse}:}{The number of \emph{zero} entries of a cell is supplied in addition to above, as a second argument.} \item{\code{dense}:}{Cells with \emph{non-zero} entries are expanded to a dense \code{array} and supplied to \code{FUN}.} \item{\code{all}:}{All cells are expanded to a dense \code{array} and supplied to \code{FUN}.} } Note that the memory and time consumption increases with the level of expansion. Note that the default method tries to coerce \code{x} to \code{array}. } \value{ An object of the same class as \code{x} where for class \code{simple_triplet_matrix} the values are always of type \code{double} if \code{FUN = sum} (default). The \code{dimnames} corresponding to \code{MARGIN} are based on (the components of) \code{INDEX}. } \author{ Christian Buchta } \note{ Currently most of the code is written in R and, therefore, the memory and time it consumes is not optimal. } \seealso{ \code{\link{simple_triplet_matrix}} and \code{\link{simple_sparse_array}} for sparse arrays. \code{\link{apply}} for dense arrays. } \examples{ ## x <- matrix(c(1, 0, 0, 2, 1, NA), nrow = 2, dimnames = list(A = 1:2, B = 1:3)) x apply(x, 1L, sum, na.rm = TRUE) ## rollup(x, 2L, na.rm = TRUE) ## rollup(x, 2L, c(1,2,1), na.rm = TRUE) ## omit rollup(x, 2L, c(1,NA,1), na.rm = TRUE) ## expand a <- as.simple_sparse_array(x) a r <- rollup(a, 1L, FUN = mean, na.rm = TRUE, EXPAND = "dense") as.array(r) ## r <- rollup(a, 1L, FUN = function(x, nz) length(x) / (length(x) + nz), EXPAND = "sparse" ) as.array(r) } \keyword{array} \keyword{algebra} \keyword{arith}