slam/0000755000175100001440000000000013020043367011222 5ustar hornikusersslam/tests/0000755000175100001440000000000013017745216012374 5ustar hornikusersslam/tests/extract.Rout.save0000644000175100001440000001450012752305174015656 0ustar hornikusers R version 3.3.1 (2016-06-21) -- "Bug in Your Hair" Copyright (C) 2016 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 > > try(x[as.logical(k)]) ## wrong type Error in `[.simple_sparse_array`(x, as.logical(k)) : Logical vector subscripting currently not implemented. > ## 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[cbind(c(0, 1), c(-1, 0))] ## allowed integer(0) > > ## > 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 > > x[as.logical(k)] ## wrong type [1] 1 2 3 4 > ## 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[cbind(c(0, 1), c(-1, 0))] ## allowed integer(0) > > 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 > > > ## > m <- matrix(c(1, 1, 0, 2), nrow = 2) > m [,1] [,2] [1,] 1 0 [2,] 1 2 > s <- as.simple_triplet_matrix(m) > identical(s[s > 0], m[m > 0]) [1] TRUE > identical(s[s > 0], s$v) ## not guaranteed [1] TRUE > local({ + s[s > 0] <- 3 + m[m > 0] <- 3 + identical(as.matrix(s), m) + }) [1] TRUE > > try(s[s]) Error in .stm_as_subscript(i, c(nr, nc)) : Not implemented. > a <- as.simple_sparse_array(s) > try(s[a]) Error in `[.simple_triplet_matrix`(s, a) : Invalid subscript type: list. > > is.na(m) <- 2 > m [,1] [,2] [1,] 1 0 [2,] NA 2 > s <- as.simple_triplet_matrix(m) > identical(s[s > 0], m[m > 0]) [1] TRUE > > local({ + s[s > 0] <- 3 + m[m > 0] <- 3 + identical(as.matrix(s), m) + }) [1] TRUE > > ### > > proc.time() user system elapsed 0.228 0.024 0.246 slam/tests/stm.R0000644000175100001440000000510512732152371013320 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)) local({ x[] <- as.double(x) xst <- as.simple_triplet_matrix(x) identical(rowSums(x), row_sums(xst)) }) local({ x[] <- as.complex(x) xst <- as.simple_triplet_matrix(x) identical(rowSums(x), row_sums(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)) local({ xna[] <- as.double(xna) xnast <- as.simple_triplet_matrix(xna) identical(rowSums(xna), row_sums(xnast)) }) local({ xna[] <- as.complex(xna) xnast <- as.simple_triplet_matrix(xna) identical(rowSums(xna), row_sums(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)) local({ xna[] <- as.double(xna) xnast <- as.simple_triplet_matrix(xna) identical(rowSums(xna, na.rm = TRUE), row_sums(xnast, na.rm = TRUE)) }) local({ xna[] <- as.complex(xna) xnast <- as.simple_triplet_matrix(xna) identical(rowSums(xna, na.rm = TRUE), row_sums(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.save0000644000175100001440000000630612732152371015333 0ustar hornikusers R version 3.3.0 (2016-05-03) -- "Supposedly Educational" Copyright (C) 2016 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") > 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 > > local({ + x[] <- as.complex(x) + s <- as.simple_triplet_matrix(x) + identical(apply(x, 2L, var), colapply_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 > > ### > > proc.time() user system elapsed 0.208 0.020 0.224 slam/tests/stm_rollup.R0000644000175100001440000000423012732152371014713 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))) ## local({ s$v <- as.complex(s$v) z <- as.matrix(s) 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))) ## local({ s$v <- as.complex(s$v) z <- as.matrix(s) 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))) ## reduce is.na(s$v) <- s$i == 1L z <- rollup(as.simple_sparse_array(s), 2L, na.rm = TRUE) z <- reduce_simple_sparse_array(z, order = TRUE) z <- as.simple_triplet_matrix(z) identical(z, .Call(slam:::R_row_tsums, s, rep(factor(1L), ncol(s)), TRUE, TRUE, TRUE)) s$v <- as.complex(s$v) z <- rollup(as.simple_sparse_array(s), 2L, na.rm = TRUE) z <- reduce_simple_sparse_array(z, order = TRUE) z <- as.simple_triplet_matrix(z) identical(z, rollup(s, 2L, na.rm = TRUE, REDUCE = 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.save0000644000175100001440000001210412752305174016200 0ustar hornikusers R version 3.3.1 (2016-06-21) -- "Bug in Your Hair" Copyright (C) 2016 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 > > as.vector(x[1,1,1]) [1] 0 > x[1L] <- NA > as.vector(x[1,1,1]) [1] NA > > x[1L] <- 2 > as.vector(x[1,1,1]) [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 [,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.216 0.020 0.232 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.save0000644000175100001440000001243412732152371015010 0ustar hornikusers R version 3.3.0 (2016-05-03) -- "Supposedly Educational" Copyright (C) 2016 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") > 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 > > local({ + x[] <- as.double(x) + xst <- as.simple_triplet_matrix(x) + identical(rowSums(x), row_sums(xst)) + }) [1] TRUE > > local({ + x[] <- as.complex(x) + xst <- as.simple_triplet_matrix(x) + identical(rowSums(x), row_sums(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 > > local({ + xna[] <- as.double(xna) + xnast <- as.simple_triplet_matrix(xna) + identical(rowSums(xna), row_sums(xnast)) + }) [1] TRUE > > local({ + xna[] <- as.complex(xna) + xnast <- as.simple_triplet_matrix(xna) + identical(rowSums(xna), row_sums(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 > > local({ + xna[] <- as.double(xna) + xnast <- as.simple_triplet_matrix(xna) + identical(rowSums(xna, na.rm = TRUE), row_sums(xnast, na.rm = TRUE)) + }) [1] TRUE > > local({ + xna[] <- as.complex(xna) + xnast <- as.simple_triplet_matrix(xna) + identical(rowSums(xna, na.rm = TRUE), row_sums(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 > > ### > > > > proc.time() user system elapsed 0.180 0.032 0.207 slam/tests/util.Rout.save0000644000175100001440000001143113013524010015140 0ustar hornikusers R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch" Copyright (C) 2016 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") > > ## > .Call("_part_index", factor(rep(1L, 4L))) [1] 1 2 3 4 attr(,"table") [1] 4 > .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 > .Call("_match_matrix", x, matrix(0L, 0, 2), 0L) [[1]] [1] 1 1 2 3 2 [[2]] integer(0) > > > ## > 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 > > ### > > proc.time() user system elapsed 0.244 0.024 0.263 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.R0000644000175100001440000000354012752305174014517 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)) as.vector(x[1,1,1]) x[1L] <- NA as.vector(x[1,1,1]) x[1L] <- 2 as.vector(x[1,1,1]) ## 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.R0000644000175100001440000000375512732152371013653 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)) local({ x[] <- as.complex(x) s <- as.simple_triplet_matrix(x) identical(apply(x, 2L, var), colapply_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/split.R0000644000175100001440000000122113017740570013644 0ustar hornikuserslibrary("slam") m <- matrix(c(2, 5, 0, 8, 0, 0, 0, 0, 0, 0, 0, 0, 3, 2, 1), nr = 3, nc = 5, byrow = TRUE, dimnames = list(c("X", "Y", "Z"), LETTERS[1 : 5])) x <- as.simple_triplet_matrix(m) identical( lapply(split(x, c(1, 2, 2)), as.matrix), split.data.frame(m, c(1, 2, 2)) ) identical( lapply(split(x, c(1, NA, 2)), as.matrix), split.data.frame(m, c(1, NA, 2)) ) local({ colnames(x) <- NULL x[] <- 0 identical( lapply(split(x, c(1, 1, 2, 2, 3), MARGIN = 2), as.matrix), lapply(split.data.frame(as.matrix(t(x)), c(1, 1, 2, 2, 3)), t) ) }) 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.save0000644000175100001440000000505212726456735015536 0ustar hornikusers R version 3.3.0 (2016-05-03) -- "Supposedly Educational" Copyright (C) 2016 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 <- 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 > > > ## 2016/6 > s <- simple_sparse_zero_array(dim = c(2, 3, 4)) > z <- rollup(s, 1:2) > identical(as.array(z), + rollup(as.array(s), 1:2)) [1] TRUE > > ### > > proc.time() user system elapsed 0.200 0.020 0.216 slam/tests/extract.R0000644000175100001440000000507712752305174014202 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] try(x[as.logical(k)]) ## wrong type ## 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[cbind(c(0, 1), c(-1, 0))] ## 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] x[as.logical(k)] ## wrong type ## 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[cbind(c(0, 1), c(-1, 0))] ## 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),] ## m <- matrix(c(1, 1, 0, 2), nrow = 2) m s <- as.simple_triplet_matrix(m) identical(s[s > 0], m[m > 0]) identical(s[s > 0], s$v) ## not guaranteed local({ s[s > 0] <- 3 m[m > 0] <- 3 identical(as.matrix(s), m) }) try(s[s]) a <- as.simple_sparse_array(s) try(s[a]) is.na(m) <- 2 m s <- as.simple_triplet_matrix(m) identical(s[s > 0], m[m > 0]) local({ s[s > 0] <- 3 m[m > 0] <- 3 identical(as.matrix(s), m) }) ### slam/tests/util.R0000644000175100001440000000241613013524010013456 0ustar hornikusers library("slam") ## .Call("_part_index", factor(rep(1L, 4L))) .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) .Call("_match_matrix", x, matrix(0L, 0, 2), 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.save0000644000175100001440000000655312732152371016412 0ustar hornikusers R version 3.3.0 (2016-05-03) -- "Supposedly Educational" Copyright (C) 2016 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") > 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 > ## > local({ + s$v <- as.complex(s$v) + z <- as.matrix(s) + 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 > > ## > local({ + s$v <- as.complex(s$v) + z <- as.matrix(s) + 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 > > ## reduce > is.na(s$v) <- s$i == 1L > > z <- rollup(as.simple_sparse_array(s), 2L, na.rm = TRUE) > z <- reduce_simple_sparse_array(z, order = TRUE) > z <- as.simple_triplet_matrix(z) > identical(z, + .Call(slam:::R_row_tsums, s, rep(factor(1L), ncol(s)), + TRUE, TRUE, TRUE)) _row_tsums: reduced 1 (3) zeros _row_tsums: 0.000s [0.000s/0.000s] [1] TRUE > > s$v <- as.complex(s$v) > > z <- rollup(as.simple_sparse_array(s), 2L, na.rm = TRUE) > z <- reduce_simple_sparse_array(z, order = TRUE) > z <- as.simple_triplet_matrix(z) > identical(z, + rollup(s, 2L, na.rm = TRUE, REDUCE = TRUE)) [1] TRUE > ### > > proc.time() user system elapsed 0.196 0.024 0.217 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/split.Rout.save0000644000175100001440000000264113017740570015340 0ustar hornikusers R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch" Copyright (C) 2016 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") > > m <- matrix(c(2, 5, 0, 8, 0, + 0, 0, 0, 0, 0, + 0, 0, 3, 2, 1), + nr = 3, nc = 5, byrow = TRUE, + dimnames = list(c("X", "Y", "Z"), + LETTERS[1 : 5])) > x <- as.simple_triplet_matrix(m) > > identical( + lapply(split(x, c(1, 2, 2)), as.matrix), + split.data.frame(m, c(1, 2, 2)) + ) [1] TRUE > identical( + lapply(split(x, c(1, NA, 2)), as.matrix), + split.data.frame(m, c(1, NA, 2)) + ) [1] TRUE > > local({ + colnames(x) <- NULL + x[] <- 0 + identical( + lapply(split(x, c(1, 1, 2, 2, 3), MARGIN = 2), as.matrix), + lapply(split.data.frame(as.matrix(t(x)), c(1, 1, 2, 2, 3)), t) + ) + }) [1] TRUE > > > proc.time() user system elapsed 0.232 0.036 0.261 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.R0000644000175100001440000000260312726456735014050 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"))) ## 2016/6 s <- simple_sparse_zero_array(dim = c(2, 3, 4)) z <- rollup(s, 1:2) identical(as.array(z), rollup(as.array(s), 1:2)) ### 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/0000755000175100001440000000000013013524010012000 5ustar hornikusersslam/src/Makevars0000644000175100001440000000004113017745216013510 0ustar hornikusersPKG_LIBS = $(BLAS_LIBS) $(FLIBS) slam/src/util.c0000644000175100001440000002046213017745216013146 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 (!isNull(y)) { 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.c0000644000175100001440000000776213017745216013326 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.c0000644000175100001440000001357313017745216013643 0ustar hornikusers#include #include #include extern int _valid_stm(SEXP x); // ceeboo 2010/8+10, 2016/6 // // 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_reduce, 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"); if (TYPEOF(R_na_rm) != LGLSXP) error("'na_rm' not logical"); if (!LENGTH(R_na_rm)) error("'na_rm' invalid length"); int na_rm = LOGICAL(R_na_rm)[0] == TRUE; if (TYPEOF(R_reduce) != LGLSXP) error("'reduce' not logical"); if (!LENGTH(R_reduce)) error("'reduce' 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++; } 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, 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 _v = VECTOR_ELT(x, 2); switch (TYPEOF(_v)) { case LGLSXP: case INTSXP: { // NOTE use REALSXP to avoid overflows. SET_VECTOR_ELT(r, 2, (__v = allocVector(REALSXP, n))); double *_z = NULL; n = 0; k = 0; 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 (!na_rm) *_z = NA_REAL; } } break; case REALSXP: { SET_VECTOR_ELT(r, 2, (__v = allocVector(REALSXP, n))); double *_z = NULL; n = 0; k = 0; 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]]; if (!na_rm || !ISNAN(z)) *_z += z; } } break; case CPLXSXP: { SET_VECTOR_ELT(r, 2, (__v = allocVector(CPLXSXP, n))); Rcomplex *_z = NULL; n = 0; k = 0; 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 = COMPLEX(__v) + n; _z->r = 0; _z->i = 0; n++; } Rcomplex *z = COMPLEX(_v) + q[i]; if (!na_rm || (!ISNAN(z->r) && !ISNAN(z->i))) { _z->r += z->r; _z->i += z->i; } } } break; default: error("type of 'v' invalid"); } // remove zeros if (*LOGICAL(R_reduce)) { k = n; n = 0; if (TYPEOF(__v) == CPLXSXP) for (int i = 0; i < k; i++) { if (COMPLEX(__v)[i].r == 0.0 && COMPLEX(__v)[i].i == 0.0) continue; if (i > n) { INTEGER(__i)[n] = INTEGER(__i)[i]; INTEGER( _j)[n] = INTEGER( _j)[i]; COMPLEX(__v)[n] = COMPLEX(__v)[i]; } n++; } else for (int i = 0; i < k; i++) { if (REAL(__v)[i] == 0.0) continue; if (i > n) { INTEGER(__i)[n] = INTEGER(__i)[i]; INTEGER( _j)[n] = INTEGER( _j)[i]; REAL(__v)[n] = REAL(__v)[i]; } n++; } if (n < k) { SETLENGTH(__i, n); SETLENGTH( _j, n); SETLENGTH(__v, n); } } #ifdef _TIME_H t2 = clock(); if (R_verbose && *LOGICAL(R_verbose)) { if (*LOGICAL(R_reduce)) Rprintf("_row_tsums: reduced %i (%i) zeros\n", k - n, n); 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.c0000644000175100001440000004776513017745216013505 0ustar hornikusers#include #include #include #include #include // ceeboo 2009/5,10,12 2010/1,5,6 2011/2 2012/4,5 2013/10 2016/6 // // 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 of 'x' 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 (!LENGTH(R_dim)) error("'dim' invalid length"); if (TYPEOF(R_na_rm) != LGLSXP) error("'na.rm' not of type logical"); if (!LENGTH(R_na_rm)) error("'na.rm' invalid length"); 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]; SEXP r = NULL; SEXP _x_ = VECTOR_ELT(x, 2); switch (TYPEOF(_x_)) { case LGLSXP: case INTSXP: { // for the type of the return argument see the behavior // of rowSums and colSums for matrix. r = PROTECT(allocVector(REALSXP, n)); memset(REAL(r), 0, sizeof(double) * n); // offset one-based indexing double *__r__ = REAL(r) - 1; int *k, *__x__ = INTEGER(_x_); if (*LOGICAL(R_na_rm)) { for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) if (*__x__ == NA_INTEGER) continue; else __r__[*i] += (double) *__x__; } else { for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) if (*__x__ == NA_INTEGER) __r__[*i] = NA_REAL; // map NA else __r__[*i] += (double) *__x__; } break; } case REALSXP: { r = PROTECT(allocVector(REALSXP, n)); memset(REAL(r), 0, sizeof(double) * n); double *__r__ = REAL(r) - 1; double *k, *__x__ = REAL(_x_); if (*LOGICAL(R_na_rm)) { for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) if (ISNAN(*__x__)) continue; else __r__[*i] += *__x__; } else for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) __r__[*i] += *__x__; break; } case CPLXSXP: { r = PROTECT(allocVector(CPLXSXP, n)); memset(COMPLEX(r), 0, sizeof(Rcomplex) * n); Rcomplex *__r__ = COMPLEX(r) - 1; Rcomplex *k, *__x__ = COMPLEX(_x_); if (*LOGICAL(R_na_rm)) { for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) if (ISNAN(__x__->r) || ISNAN(__x__->i)) continue; else { __r__[*i].r += __x__->r; __r__[*i].i += __x__->i; } } else for (k = __x__ + LENGTH(_x_); __x__ < k; __x__++, i++) { __r__[*i].r += __x__->r; __r__[*i].i += __x__->i; } break; } default: error("type of 'x' invalid"); } 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/NAMESPACE0000644000175100001440000001241313017617123012445 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("split", "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", "_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" ) ## ## export("unfold", ## "fold") ## S3method("unfold", "default") ## S3method("unfold", "matrix") ## S3method("unfold", "array") ## S3method("unfold", "simple_triplet_matrix") ## S3method("unfold", "simple_sparse_array") ## S3method("fold", "default") ## S3method("fold", "matrix") ## S3method("fold", "array") ## S3method("fold", "simple_triplet_matrix") ## S3method("fold", "simple_sparse_array") ## export("slam_options") slam/R/0000755000175100001440000000000013017745216011433 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.R0000644000175100001440000000634012731673472013036 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 <- i[[1L]] attributes(i) <- list(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.R0000644000175100001440000001055712755134131013560 0ustar hornikusers## CB 2012/9 2016/8 ## ## 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 <- pd > slam_options("max_dense") na <- nargs() if (na == 3L && missing(..1)) if (.disable) stop("Empty subscripting disabled.") else return( `[<-.simple_sparse_array`(x, seq_len(pd), value = value) ) ## Single index subscripting. if (na == 3L) { I <- ..1 ## NOTE mapping to matrix is less inefficient (see below). I <- .stm_as_subscript(I, x$dim, TRUE) if (!is.numeric(unclass(I))) stop("Only numeric / matrix 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)) { if (log2(pd) > .Machine$double.digits) 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 (.disable) 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 (.disable) 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 (.disable) { 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_len(value, 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 <- which(V == vector(typeof(V), 1L)) if (length(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.R0000644000175100001440000002431112755134131012671 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 } Ops.simple_sparse_array <- function(e1, e2) { stop("Not implemented.") } 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) pd <- prod(x$dim) ## See now matrix.R for comment. .protect <- pd > slam_options("max_dense") ## Note there is a limit to representing integer numbers as ## doubles (see above). 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 vector subscripting currently not implemented.") else if(is.character(i)) stop("Character vector subscripting currently not implemented.") else if(!is.matrix(i)) { if (!is.numeric(unclass(i))) stop(gettextf("Invalid subscript type: %s.", typeof(i)), domain = NA) if(log2(pd) > .Machine$double.digits) 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 > pd 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(.protect) stop("Negative vector subsripting disabled for this object.") out <- vector(mode = typeof(x$v), pd) 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 || !is.numeric(i)) return(do.call("[.simple_sparse_array", list(x = x, as.vector(i)))) if(is.double(i)) i <- trunc(i) k <- .Call(R_all_row, i > 0, FALSE) i <- i[k, , drop = FALSE] ## Note that negative values are not allowed in a matrix ## subscript. if(any(i < 0, na.rm = TRUE)) stop("Invalid subscript.") 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/misc.R0000644000175100001440000000040612755134131012505 0ustar hornikusers ## slam_options <- local({ options <- list(max_dense = 2^24) function(option, value) { if (missing(option)) return(options) if (missing(value)) options[[option]] else options[[option]] <<- value } }) slam/R/rollup.R0000644000175100001440000001565212731673472013112 0ustar hornikusers### rollup <- function(x, MARGIN, INDEX, FUN, ...) UseMethod("rollup") rollup.array <- function(x, MARGIN, INDEX = NULL, FUN = sum, ..., DROP = FALSE, MODE = "double") { 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)) rep(factor(1L), d[k]) 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) attributes(i) <- list(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) if (is.null(i)) i <- vector(MODE, 0L) } ## 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"), MODE = "double") { 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)]] if (is.null(z)) { ## NOTE defer processing. if (EXPAND < 3L) { if (EXPAND > 1L) T[[k]] <- D[k] D[k] <- -1L next } z <- rep(factor(1L), D[k]) } else { if (length(z) != D[k]) stop(gettextf("INDEX [%s] invalid length", k), domain = NA) z <- 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 { if (EXPAND < 3L) { i <- which(D == -1L) if (length(i)) { D[i] <- 1L N[i] <- list("1") I[, i] <- 1L } } i <- .Call(R_match_matrix, I, NULL, NULL) I <- I[i[[2L]],, drop = FALSE] i <- i[[1L]] } attributes(i) <- list(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) if (is.null(V)) V <- vector(MODE, 0L) 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, ..., REDUCE = FALSE) { 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)) rep(factor(1L), dim(x)[k]) 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), as.logical(REDUCE), FALSE ## verbose ) } ) } x } ## rollup.default <- function(x, MARGIN, INDEX = NULL, FUN = sum, ..., DROP = FALSE, MODE = "double") { if (!length(dim(x))) stop("dim(x) must have a positive length") rollup(as.array(x), MARGIN, INDEX, FUN, ..., DROP = DROP, MODE = MODE) } ### slam/R/matrix.R0000644000175100001440000007036013017740570013066 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_triplet_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), prod(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) pos <- .Call(R_match_matrix, cbind(e1$i, e1$j), cbind(e2$i, e2$j), 0L)[[2L]] 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) pos <- .Call(R_match_matrix, cbind(e1$i, e1$j), cbind(e2$i, e2$j), 0L)[[2L]] 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) != prod(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 } ## For reuse in other functions (we want to mess up, too). .stm_as_subscript <- function(x, d, safe = FALSE, ...) { if (!is.simple_triplet_matrix(x)) return(x) if (!is.logical(x$v) || !identical(dim(x), d)) stop("Not implemented.") ## need column-major order k <- order(x$j, x$i) if (any(diff(k < 0))) { x$v <- x$v[k] x$i <- x$i[k] x$j <- x$j[k] } ## offer a choice if (safe || log2(prod(dim(x))) > .Machine$double.digits) cbind(x$i[x$v], x$j[x$v]) else ## need to use a double in expression to ## get a result of type double ((x$j - 1) * x$nrow + x$i)[x$v] } `[.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 pd <- prod(nr, nc) ## FIXME eventually, we should get rid of ill-conceived features ## which need to expand to dense. .disable <- pd > slam_options("max_dense") if(na == 2L) { ## Single index subscripting. ## Mimic subscripting matrices: no named argument handling in ## this case. ## FIXME mapping to numeric seems to be less inefficient. i <- .stm_as_subscript(i, c(nr, nc)) if(is.character(i)) out <- vector(typeof(x$v))[rep.int(NA, length(i))] else if(!is.matrix(i)) { if(is.logical(i)) { if(.disable) stop("Logical vector subscripting disabled for this object.") i <- which(rep_len(i, pd)) } else if(!is.numeric(unclass(i))) stop(gettextf("Invalid subscript type: %s.", typeof(i)), domain = NA) else if(log2(pd) > .Machine$double.digits) 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 > pd is.na(out) <- is.na(i) i <- match(i, (x$j - 1) * nr + x$i, 0L) out[i > 0L] <- x$v[i] } } else if(!any(is.na(i)) && all(i <= 0)) { if(.disable) stop("Negative vector subscripting disabled for this object.") out <- vector(mode = typeof(x$v), pd) 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 || !is.numeric(i)) return(do.call("[.simple_triplet_matrix", list(x = x, as.vector(i)))) if(is.double(i)) i <- trunc(i) ## 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] ## Note that negative values are not allowed in a matrix ## subscript. if(any(i < 0, na.rm = TRUE)) stop("Invalid subscript.") 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_len(i, 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_len(j, 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), prod(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) split.simple_triplet_matrix <- function(x, f, drop = FALSE, MARGIN = 1L, ...) { if(!is.factor(f)) f <- as.factor(f) else if(drop) f <- factor(f) if (length(MARGIN) != 1L || is.na(match(MARGIN, 1:2))) stop("'MARGIN' invalid") if (length(f) != dim(x)[MARGIN]) stop("'f' invalid length") fx <- f[x[[MARGIN]]] mapply(function(i, j, v, k) { z <- x z$i <- i z$j <- j z$v <- v z[[MARGIN]] <- match(z[[MARGIN]], k) z[[MARGIN + 3L]] <- length(k) k <- z$dimnames[[MARGIN]][k] if (!is.null(k)) z$dimnames[[MARGIN]] <- k if (!.Call(R__valid_stm, z)) stop("oops, invalid 'simple_triplet_matrix' object") z }, split(x$i, fx), split(x$j, fx), split(x$v, fx), split(seq_along(f), f), SIMPLIFY = FALSE ) } ## 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_len(v, nrow) i <- seq_len(nrow) simple_triplet_matrix(i, i, v, nrow, nrow) } slam/MD50000644000175100001440000000640613020043367011540 0ustar hornikusersd26cceb9fed958d5d63d4ca45b5d307d *DESCRIPTION dbe4b7b980e8d6f666f8bf88e5085ab7 *NAMESPACE 6da5f4bb978d5d2ab7de8ddd6c977571 *R/abind.R b94f005638ee208bb4417ccb4893aa68 *R/apply.R 316ab8fb22bed3b54d1f9377823e3292 *R/array.R 41e489be2096cfeb9698676b24c5cd99 *R/crossprod.R c4c13f3dd3aa408f21c3588a110790ac *R/foreign.R 2e77160750e8b134acb1dc67e0a9af3d *R/matrix.R 52edd441e5d9c1465b43128009619fc8 *R/misc.R 6b2f1647dbce506a9ef4e42aefb92f52 *R/reduce.R c6686de20762b42b8bdec9e33955daab *R/rollup.R 081170556760537396d1c76b108027f2 *R/stm.R fedf16222496abe5aa78fd9c47ea2d6b *R/subassign.R 21736500a7b5530d1c2d5e75faee4c35 *man/abind.Rd b549d8099a6034335d09c825532c0fca *man/apply.Rd d8adcd366f2ceea79dde576c2a44c33c *man/array.Rd 57ab89e1ab8f7af331b824054f9a22a0 *man/crossprod.Rd 70074ed00c0a76ffec8f177b7c8264ca *man/foreign.Rd 2e276d68899202ed1793e18793a53a50 *man/matrix.Rd c654d2bd652ea6876766d95d6d8e8ca5 *man/norms.Rd da052c0de6ca37432ee52620c4ccbc33 *man/options.Rd 096a58899749963375c5a4b12b245d60 *man/rollup.Rd f75048a25feebac938f74e1ed79fe683 *man/sums.Rd 2fa4c7011c2bc0f7449ae151d5cc44ae *src/Makevars dc088b0ac562f358ced61cdedbbf757d *src/apply.c a6e6e502309e5bb33b5ea822a133b6f8 *src/grouped.c a0243e37e3056d9a91953144e0d9b236 *src/sparse.c 4afb8bbebf5bb56cdcfb483b8613919e *src/util.c 6e9231824027888adde90f5b525bed48 *tests/abind.R 2a747ac2d11d058340e8f0c8bc01d71e *tests/abind.Rout.save 1d6eac26b215d6fee5592782569e5232 *tests/apply.R 2db1725e5bd8911d4f1237bdf7f1e1a0 *tests/apply.Rout.save 0163073a0b1bc0d95defebb7bbeebcdd *tests/crossprod.R 50af4aa7903c8644aa566f8fa887ecdb *tests/crossprod.Rout.save bc27d868d522803f1ea436592cbc98f1 *tests/dimgets.R 47094f0cdbd0221720da15fbd6fa94b3 *tests/extract.R 910d2252a27541de406b63babba0f96a *tests/extract.Rout.save a3f7839ed3a231dc02f704df7333ba70 *tests/matrix.R b86c28c833275f95a0640bda242e0cbb *tests/matrix.Rout.save 1aedaf99201b77a1074e9118bc5704d2 *tests/matrix_dimnames.R 0a73c3fcb1cf31632db30941809f2b1d *tests/matrix_dimnames.Rout.save 81f3ceea72c7debaeded0e0a38dee245 *tests/rollup.R 4c4203fcac718fc625cf1be8614981a3 *tests/rollup.Rout.save 4e140e3ed76ef390637d93f979263c6b *tests/split.R 13be5b14a4b4252d7b3025bef82eaac1 *tests/split.Rout.save 46fd1f36f27c217c9840e0de65dcc4ad *tests/ssa_valid.R 643da57c362b62fa828dbf402b42ac9d *tests/ssa_valid.Rout.save 66dbe36adfdca7a24024768b92474229 *tests/stm.R 59f684bb84b62a0f6329b5e8f7c79553 *tests/stm.Rout.save c08e0dd2853dd24d35c71fb05b0c3998 *tests/stm_apply.R 6d6c5b37fc83131692759b25f3b0dd75 *tests/stm_apply.Rout.save 6ec22193d6ab30c20bdcf70bab31075a *tests/stm_rollup.R 1060030451083e6a756fd4257cf9bca3 *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 e462d22111cf4059d2e40cb07a9577b2 *tests/subassign.R 64ce23d54028bd2ac5da70109243c705 *tests/subassign.Rout.save f436242c6448866d1bd235de2c699fd6 *tests/util.R 0b973790d75795b974791722ea7ef203 *tests/util.Rout.save slam/DESCRIPTION0000644000175100001440000000142713020043367012734 0ustar hornikusersPackage: slam Version: 0.1-40 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 (>= 3.3.1) Imports: stats Enhances: Matrix, SparseM, spam License: GPL-2 NeedsCompilation: yes Packaged: 2016-12-01 07:00:30 UTC; hornik Author: Kurt Hornik [aut, cre], David Meyer [aut], Christian Buchta [aut] Maintainer: Kurt Hornik Repository: CRAN Date/Publication: 2016-12-01 16:51:19 slam/man/0000755000175100001440000000000013017745216012005 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/options.Rd0000644000175100001440000000157512755134131013773 0ustar hornikusers\name{options} \alias{slam_options} \title{Options for the `slam' package} \description{Function for getting and setting options for the \pkg{slam} package.} \usage{ slam_options(option, value) } \arguments{ \item{option}{character string indicating the option to get or set (see details). If missing, all options are returned as a list.} \item{value}{Value to be set. If omitted, the current value is returned.} } \details{ Currently, the following options are available: \describe{ \item{\code{"max_dense"}:}{numeric specifying the maximum \code{length} of dense vectors (default: \code{2^24}). } } } \seealso{ \code{\link{simple_sparse_array}} } \examples{ ## save defaults .slam_options <- slam_options() .slam_options slam_options("max_dense", 2^25) slam_options("max_dense") ## reset slam_options("max_dense", .slam_options$max_dense) } \keyword{math} slam/man/array.Rd0000644000175100001440000000633712755134131013417 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)) > slam_options("max_dense")} 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. \code{\link{slam_options}} for options. } \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.Rd0000644000175100001440000000713512731673472013625 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, REDUCE = FALSE) \method{rollup}{simple_sparse_array}(x, MARGIN, INDEX = NULL, FUN = sum, \dots, DROP = FALSE, EXPAND = c("none", "sparse", "dense", "all"), MODE = "double") \method{rollup}{matrix}(x, MARGIN, INDEX = NULL, FUN = sum, \dots, DROP = FALSE, MODE = "double") \method{rollup}{array}(x, MARGIN, INDEX = NULL, FUN = sum, \dots, DROP = FALSE, MODE = "double") } \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{REDUCE}{option to remove zeros from the result.} \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{MODE}{the type to use for the values if the result is empty. } \item{\dots}{optional arguments to \code{FUN}. } } \details{ Provides aggregation of sparse and dense arrays, in particular 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}