slam/ 0000755 0001751 0000144 00000000000 14652414325 011232 5 ustar hornik users slam/tests/ 0000755 0001751 0000144 00000000000 14652376275 012407 5 ustar hornik users slam/tests/stm.R 0000644 0001751 0000144 00000005230 13436222460 013316 0 ustar hornik users
library("slam")
##
## Remove eventually.
suppressWarnings(RNGversion("3.5.0"))
##
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_zeros.R 0000644 0001751 0000144 00000003573 13436222501 014544 0 ustar hornik users
library("slam")
##
## Remove eventually.
suppressWarnings(RNGversion("3.5.0"))
##
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/ssa_valid.Rout.save 0000644 0001751 0000144 00000002642 14166005250 016146 0 ustar hornik users
R Under development (unstable) (2022-01-05 r81451) -- "Unsuffered Consequences"
Copyright (C) 2022 The R Foundation for Statistical Computing
Platform: x86_64-pc-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)
>
> ## zero dimension
> a <- as.simple_sparse_array(array(0L, 0L))
> drop_simple_sparse_array(a)
integer(0)
>
> ## invalid
> a <- simple_sparse_array(c(1L, 2L), c(1L, -1L))
> a$i[2L] <- 1L
> a <- reduce_simple_sparse_array(a)
Warning message:
In reduce_simple_sparse_array(a) : NAs introduced by reduction
> as.array(a)
[1] NA 0
>
> ## 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(slam:::R__valid_v, vector(typeof(v), 1L)))))
>
> ##
>
> proc.time()
user system elapsed
0.134 0.016 0.143
slam/tests/stm.Rout.save 0000644 0001751 0000144 00000012620 13436222741 015006 0 ustar hornik users
R Under development (unstable) (2019-03-01 r76185) -- "Unsuffered Consequences"
Copyright (C) 2019 The R Foundation for Statistical Computing
Platform: x86_64-pc-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")
> ##
> ## Remove eventually.
> suppressWarnings(RNGversion("3.5.0"))
> ##
> 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.111 0.013 0.116
slam/tests/stm_subassign.R 0000644 0001751 0000144 00000000550 12103507072 015367 0 ustar hornik users
##
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/extract.Rout.save 0000644 0001751 0000144 00000014514 13037465141 015661 0 ustar hornik users
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(slam:::R_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(slam:::R_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/matrix_dimnames.R 0000644 0001751 0000144 00000000633 11502441401 015664 0 ustar hornik users
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/stm_valid.R 0000644 0001751 0000144 00000000347 11527416634 014510 0 ustar hornik users
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/abind.R 0000644 0001751 0000144 00000001574 11753474631 013610 0 ustar hornik users ##
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_zeros.Rout.save 0000644 0001751 0000144 00000010752 13436222767 016244 0 ustar hornik users
R Under development (unstable) (2019-03-01 r76185) -- "Unsuffered Consequences"
Copyright (C) 2019 The R Foundation for Statistical Computing
Platform: x86_64-pc-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")
> ##
> ## Remove eventually.
> suppressWarnings(RNGversion("3.5.0"))
> ##
> 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
>
> ###
>
>
>
> proc.time()
user system elapsed
0.130 0.036 0.159
slam/tests/dimgets.R 0000644 0001751 0000144 00000000750 12262026562 014152 0 ustar hornik users require("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/rollup.R 0000644 0001751 0000144 00000002603 12726456735 014050 0 ustar hornik users
##
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/stm_rollup.Rout.save 0000644 0001751 0000144 00000006657 14145217601 016415 0 ustar hornik users
R Under development (unstable) (2021-11-16 r81199) -- "Unsuffered Consequences"
Copyright (C) 2021 The R Foundation for Statistical Computing
Platform: x86_64-pc-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")
> 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:
In rollup.simple_triplet_matrix(s, 2L, k) : 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.136 0.012 0.140
slam/tests/matrix.R 0000644 0001751 0000144 00000001422 11312355131 014007 0 ustar hornik users
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/tests/rollup.Rout.save 0000644 0001751 0000144 00000004650 13577401512 015525 0 ustar hornik users
R Under development (unstable) (2019-12-20 r77608) -- "Unsuffered Consequences"
Copyright (C) 2019 The R Foundation for Statistical Computing
Platform: x86_64-pc-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(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")))
[1] TRUE
> identical(as.array(z),
+ as.array(rollup(a, 2L, c(1,2,1), na.rm = TRUE, EXPAND = "all")))
[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")))
[1] TRUE
> identical(as.array(z),
+ as.array(rollup(a, 2L, c(1,NA,1), na.rm = TRUE, EXPAND = "all")))
[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")))
[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.110 0.025 0.125
slam/tests/apply.R 0000644 0001751 0000144 00000003755 12732152371 013653 0 ustar hornik users
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.save 0000644 0001751 0000144 00000002146 11502441401 017352 0 ustar hornik users
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_ttcrossprod.Rout.save 0000644 0001751 0000144 00000002432 11443342170 017447 0 ustar hornik users
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/split.Rout.save 0000644 0001751 0000144 00000002641 13017740570 015340 0 ustar hornik users
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/extract.R 0000644 0001751 0000144 00000005113 13037465141 014167 0 ustar hornik users ##
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(slam:::R_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(slam:::R_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/stm_subassign.Rout.save 0000644 0001751 0000144 00000003033 12103507072 017053 0 ustar hornik users
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/crossprod.R 0000644 0001751 0000144 00000001735 12254246630 014541 0 ustar hornik users
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_rollup.R 0000644 0001751 0000144 00000004230 12732152371 014713 0 ustar hornik users
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/matrix.Rout.save 0000644 0001751 0000144 00000002765 11314667363 015526 0 ustar hornik users
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/subassign.Rout.save 0000644 0001751 0000144 00000012347 13060450067 016204 0 ustar hornik users
R version 3.3.3 (2017-03-06) -- "Another Canoe"
Copyright (C) 2017 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(slam:::R_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(slam:::R_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(slam:::R_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
>
> ##
> z <- drop_simple_sparse_array(x[1,,])
> as.vector(z[1,])
[1] 2 2
> z[1,] <- -as.simple_triplet_matrix(z[1,])
> as.vector(z[1,])
[1] -2 -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.228 0.032 0.280
slam/tests/subassign.R 0000644 0001751 0000144 00000003750 13060450067 014515 0 ustar hornik users ##
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(slam:::R_vector_index, x$dim, x$i))
##
x[, -1, 1] <- 0 ## zero elements
data.frame(v = x$v, i = x$i,
k = .Call(slam:::R_vector_index, x$dim, x$i))
x[-c(2, 3)] <- 0
data.frame(v = x$v, i = x$i,
k = .Call(slam:::R_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])
##
z <- drop_simple_sparse_array(x[1,,])
as.vector(z[1,])
z[1,] <- -as.simple_triplet_matrix(z[1,])
as.vector(z[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/stm_ttcrossprod.R 0000644 0001751 0000144 00000000775 11443342170 015772 0 ustar hornik users
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/util.Rout.save 0000644 0001751 0000144 00000011627 13037465141 015166 0 ustar hornik users
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(slam:::R_part_index, factor(rep(1L, 4L)))
[1] 1 2 3 4
attr(,"table")
[1] 4
> .Call(slam:::R_part_index, factor(1:4))
[1] 1 1 1 1
attr(,"table")
[1] 1 1 1 1
> .Call(slam:::R_part_index, factor(c(1L,2L,2L,1L)))
[1] 1 1 2 2
attr(,"table")
[1] 2 2
> .Call(slam:::R_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(slam:::R_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(slam:::R_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(slam:::R_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(slam:::R_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(slam:::R_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(slam:::R_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(slam:::R_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(slam:::R_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(slam:::R_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(slam:::R_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(slam:::R_ini_array, 3L, c(1L,2L), c(1L,1L), 2L)
[1] 0 1 0
>
> .Call(slam:::R_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(slam:::R_match_matrix, x, NULL, NULL)
[[1]]
[1] 1 1 2 3 2
[[2]]
[1] 1 3 4
> .Call(slam:::R_match_matrix, x, x[1:3,], 0L)
[[1]]
[1] 1 1 2 3 2
[[2]]
[1] 1 1 2
> .Call(slam:::R_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(slam:::R_all_row, x > 1L, FALSE)
[1] FALSE TRUE NA NA NA
> .Call(slam:::R_all_row, x > 1L, TRUE)
[1] FALSE TRUE FALSE TRUE TRUE
>
> ###
>
> proc.time()
user system elapsed
0.244 0.024 0.263
slam/tests/ssa_valid.R 0000644 0001751 0000144 00000001050 14164072325 014456 0 ustar hornik users
##
library(slam)
## zero dimension
a <- as.simple_sparse_array(array(0L, 0L))
drop_simple_sparse_array(a)
## invalid
a <- simple_sparse_array(c(1L, 2L), c(1L, -1L))
a$i[2L] <- 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(slam:::R__valid_v, vector(typeof(v), 1L)))))
##
slam/tests/abind.Rout.save 0000644 0001751 0000144 00000004652 12311556616 015270 0 ustar hornik users
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_valid.Rout.save 0000644 0001751 0000144 00000001742 11527416634 016175 0 ustar hornik users
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/util.R 0000644 0001751 0000144 00000002614 13037465141 013475 0 ustar hornik users
library("slam")
##
.Call(slam:::R_part_index, factor(rep(1L, 4L)))
.Call(slam:::R_part_index, factor(1:4))
.Call(slam:::R_part_index, factor(c(1L,2L,2L,1L)))
.Call(slam:::R_part_index, factor(c(1L,2L,NA,1L)))
##
i <- 1:27
x <- arrayInd(i, .dim = c(3L,3L,3L))
.Call(slam:::R_vector_index, c(3L,3L,3L), x)
x[14L, 2L] <- NA
.Call(slam:::R_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(slam:::R_ini_array, c(3L,3L,3L), p, v, 2L)
.Call(slam:::R_ini_array, c(3L,3L,3L), p, as.logical(v), 2L)
.Call(slam:::R_ini_array, c(3L,3L,3L), p, as.double(v), 2L)
.Call(slam:::R_ini_array, c(3L,3L,3L), p, as.raw(v), 2L)
.Call(slam:::R_ini_array, c(3L,3L,3L), p, as.complex(v), 2L)
.Call(slam:::R_ini_array, c(3L,3L,3L), p, as.character(v), 2L)
.Call(slam:::R_ini_array, c(3L,3L,3L), p, as.list(v), 2L)
.Call(slam:::R_ini_array, c(3L,3L,3L), p, as.expression(v), 2L)
.Call(slam:::R_ini_array, 3L, c(1L,2L), c(1L,1L), 2L)
.Call(slam:::R_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(slam:::R_match_matrix, x, NULL, NULL)
.Call(slam:::R_match_matrix, x, x[1:3,], 0L)
.Call(slam:::R_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(slam:::R_all_row, x > 1L, FALSE)
.Call(slam:::R_all_row, x > 1L, TRUE)
###
slam/tests/stm_apply.R 0000644 0001751 0000144 00000001100 12262760225 014515 0 ustar hornik users
##
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.R 0000644 0001751 0000144 00000001221 13017740570 013644 0 ustar hornik users 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))
)
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/stm_apply.Rout.save 0000644 0001751 0000144 00000003136 12262760225 016215 0 ustar hornik users
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/crossprod.Rout.save 0000644 0001751 0000144 00000003471 12254246630 016225 0 ustar hornik users
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/apply.Rout.save 0000644 0001751 0000144 00000006306 12732152371 015333 0 ustar hornik users
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/MD5 0000644 0001751 0000144 00000006652 14652414325 011553 0 ustar hornik users 36c48d611d945941eaa0fa10e459e2db *DESCRIPTION
2c0c220f2e56211f794f12902971180d *NAMESPACE
77c5ebf37055a0dd494b8d60eae9985b *R/abind.R
b94f005638ee208bb4417ccb4893aa68 *R/apply.R
84b02e7be7e7ae4610432439312a6cc3 *R/array.R
fcbdd0a1a079444120715c6abf3ddbae *R/crossprod.R
23a43eb04ea4f250c0631fddffddce20 *R/foreign.R
5047e790220e13b434ff63e760752dd8 *R/matrix.R
52edd441e5d9c1465b43128009619fc8 *R/misc.R
70bff26550a9f0c7a514edc7a6c4466f *R/reduce.R
9be3b4207e9ec3805d31dd6ea70cd5ff *R/rollup.R
081170556760537396d1c76b108027f2 *R/stm.R
450fb37f708990339d60f6fc58481a8f *R/subassign.R
d5e4976e869418e73823e386751b5650 *inst/po/en@quot/LC_MESSAGES/R-slam.mo
21736500a7b5530d1c2d5e75faee4c35 *man/abind.Rd
b549d8099a6034335d09c825532c0fca *man/apply.Rd
d8adcd366f2ceea79dde576c2a44c33c *man/array.Rd
57ab89e1ab8f7af331b824054f9a22a0 *man/crossprod.Rd
f39044389a5615464865f18cf2a5ba47 *man/foreign.Rd
b8502c7d26801a715ee3064cff0ec90d *man/matrix.Rd
c654d2bd652ea6876766d95d6d8e8ca5 *man/norms.Rd
da052c0de6ca37432ee52620c4ccbc33 *man/options.Rd
096a58899749963375c5a4b12b245d60 *man/rollup.Rd
f75048a25feebac938f74e1ed79fe683 *man/sums.Rd
1832b116a85280523d5399cd7ac2a5a6 *po/R-slam.pot
2fa4c7011c2bc0f7449ae151d5cc44ae *src/Makevars
dc088b0ac562f358ced61cdedbbf757d *src/apply.c
eab1529358b656803537a7ccee91542c *src/dll.c
08727c340482a40d85787581b655e0fd *src/grouped.c
1c8f6467c565da19fa7bfc3d439c03f5 *src/sparse.c
8e81ea3fe1a70d3a77407334e68189fe *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
dfcbc70af3d4b50789fa02dd7be4763b *tests/extract.R
40bf4d8df26eef6e614cb8da674b1639 *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
e300757faaf2b02a6f1ef041c6abebef *tests/rollup.Rout.save
4e140e3ed76ef390637d93f979263c6b *tests/split.R
13be5b14a4b4252d7b3025bef82eaac1 *tests/split.Rout.save
1377c3e5aca20546b18ceb2ab2cf100f *tests/ssa_valid.R
145096a087ee4822e8b69fb93c6c5a1e *tests/ssa_valid.Rout.save
f48c756b0c0db0961b8959f478fedb71 *tests/stm.R
d39141a68d98a2d3281f1242681af5ed *tests/stm.Rout.save
c08e0dd2853dd24d35c71fb05b0c3998 *tests/stm_apply.R
6d6c5b37fc83131692759b25f3b0dd75 *tests/stm_apply.Rout.save
6ec22193d6ab30c20bdcf70bab31075a *tests/stm_rollup.R
6e91ba7a9e6d272a8149b030aa0ee147 *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
728ff9bc3c371a363cab3a75a5a0b4e9 *tests/stm_zeros.R
e14df64bda2beb93a385d13c72eae4e0 *tests/stm_zeros.Rout.save
8726e6238106da5de2e0f16f239899e1 *tests/subassign.R
816c7e268de781b428348b3f5e8154d0 *tests/subassign.Rout.save
c859a6ac7318b301963a165f10f6a767 *tests/util.R
24d7de0e71f07b6f9962eed134e87fed *tests/util.Rout.save
slam/po/ 0000755 0001751 0000144 00000000000 13143661650 011647 5 ustar hornik users slam/po/R-slam.pot 0000644 0001751 0000144 00000010431 13143661650 013525 0 ustar hornik users msgid ""
msgstr ""
"Project-Id-Version: slam 0.1-41\n"
"POT-Creation-Date: 2017-08-12 22:23\n"
"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
"Last-Translator: FULL NAME \n"
"Language-Team: LANGUAGE \n"
"MIME-Version: 1.0\n"
"Content-Type: text/plain; charset=CHARSET\n"
"Content-Transfer-Encoding: 8bit\n"
msgid "'x' not of class 'simple_sparse_array'"
msgstr ""
msgid "'MARGIN' invalid"
msgstr ""
msgid "lengths of 'dim' do not conform"
msgstr ""
msgid "common parts of 'dim' do not conform"
msgstr ""
msgid "definitions of ZERO of 'v' do not conform"
msgstr ""
msgid "'x' not of class simple_striplet_matrix"
msgstr ""
msgid "'x' not of class simple_triplet_matrix"
msgstr ""
msgid "the numer of rows of 'x' and 'y' do not conform"
msgstr ""
msgid "'x, y' not of class simple_triplet_matrix"
msgstr ""
msgid "failed to create a valid 'simple_sparse_array' object"
msgstr ""
msgid "Generic '%s' not defined for \"%s\" objects."
msgstr ""
msgid "Not implemented."
msgstr ""
msgid "invalid dim replacement value"
msgstr ""
msgid "Logical vector subscripting currently not implemented."
msgstr ""
msgid "Character vector subscripting currently not implemented."
msgstr ""
msgid "Invalid subscript type: %s."
msgstr ""
msgid "Numeric vector subscripting disabled for this object."
msgstr ""
msgid "Negative vector subsripting disabled for this object."
msgstr ""
msgid "Cannot mix positive and negative subscripts."
msgstr ""
msgid "Invalid subscript."
msgstr ""
msgid "subscript out of bounds"
msgstr ""
msgid "Incorrect number of dimensions."
msgstr ""
msgid "Only numeric multi-index subscripting is implemented."
msgstr ""
msgid "NA indices currently not allowed"
msgstr ""
msgid "Repeated indices currently not allowed."
msgstr ""
msgid "A simple sparse array of dimension %s."
msgstr ""
msgid "Invalid permutation."
msgstr ""
msgid "'dim' must have positive length"
msgstr ""
msgid "'transpose' not implemented"
msgstr ""
msgid "invalid matrix format"
msgstr ""
msgid "failed to create a valid 'simple_triplet_matrix' object"
msgstr ""
msgid "Unsupported number of dimensions"
msgstr ""
msgid "Unary '%s' not defined for \"%s\" objects."
msgstr ""
msgid "NA/NaN handling not implemented."
msgstr ""
msgid "Incompatible dimensions."
msgstr ""
msgid "Invalid dimnames."
msgstr ""
msgid "Invalid component length."
msgstr ""
msgid "Logical vector subscripting disabled for this object."
msgstr ""
msgid "Negative vector subscripting disabled for this object."
msgstr ""
msgid "NA indices not allowed."
msgstr ""
msgid "Subscript out of bounds."
msgstr ""
msgid "Numbers of columns of matrices must match."
msgstr ""
msgid "Numbers of rows of matrices must match."
msgstr ""
msgid "Invalid margin."
msgstr ""
msgid "A %s simple triplet matrix."
msgstr ""
msgid "'f' invalid length"
msgstr ""
msgid "oops, invalid 'simple_triplet_matrix' object"
msgstr ""
msgid "multiple entries"
msgstr ""
msgid "NAs introduced by reduction"
msgstr ""
msgid "zero entries"
msgstr ""
msgid "'INDEX' invalid length"
msgstr ""
msgid "INDEX [%s] invalid length"
msgstr ""
msgid "component 'v' contains 'ZERO' value(s)"
msgstr ""
msgid "number of cells %d too large for hashing"
msgstr ""
msgid "processing %d cells ..."
msgstr ""
msgid "'DROP' not supported"
msgstr ""
msgid "dim(x) must have a positive length"
msgstr ""
msgid "Replacement disabled."
msgstr ""
msgid "replacement has length zero"
msgstr ""
msgid "Empty subscripting disabled."
msgstr ""
msgid "Only numeric / matrix subscripting is implemented."
msgstr ""
msgid "NAs are not allowed in subscripted assignments"
msgstr ""
msgid "Vector subscripting disabled for this object."
msgstr ""
msgid "Extending is not implemented."
msgstr ""
msgid "Negative subscripting disabled for this object."
msgstr ""
msgid "only 0's may be mixed with negative subscripts"
msgstr ""
msgid "negative values are not allowed in a matrix subscript"
msgstr ""
msgid "incorrect number of dimensions"
msgstr ""
msgid "Missing dimensions disabled for this object."
msgstr ""
msgid "Only numeric subscripting is implemented."
msgstr ""
msgid "number of items to replace is not a multiple of replacement length"
msgstr ""
msgid "'MARGINS' invalid"
msgstr ""
msgid "'MARGINS' and/or 'DIM' invalid"
msgstr ""
msgid "MARGINS [%s] invalid factorization"
msgstr ""
slam/R/ 0000755 0001751 0000144 00000000000 14652376275 011446 5 ustar hornik users slam/R/stm.R 0000644 0001751 0000144 00000006551 12253654212 012364 0 ustar hornik users
## 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/abind.R 0000644 0001751 0000144 00000004675 13435047436 012652 0 ustar hornik users
##
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[!vapply(args, is.null, NA)]
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.int("", 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.int("", D[m]),
y$dimnames[[m]]
)
}
D[m] <- D[m] + y$dim[m]
x <- simple_sparse_array(I, V, D, N)
}
x
}
###
slam/R/rollup.R 0000644 0001751 0000144 00000016136 14144531356 013102 0 ustar hornik users ###
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.int(as.factor(1L), d[k])
else {
if (length(z) != d[k])
stop(gettextf("INDEX [%s] invalid length", k),
domain = NA)
as.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.int(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.int(as.factor(1L), D[k])
} else {
if (length(z) != D[k])
stop(gettextf("INDEX [%s] invalid length", k),
domain = NA)
z <- as.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 {
verbose <- getOption("verbose")
.pt <- proc.time()
if(verbose)
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)
if(verbose)
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.int(as.factor(1L), dim(x)[k])
else {
if (length(z) != dim(x)[k])
stop(gettextf("INDEX [%s] invalid length", k),
domain = NA)
as.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.R 0000644 0001751 0000144 00000071713 14652375553 013104 0 ustar hornik users ## 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)
if(anyDuplicated(cbind(stm$i, stm$j)) > 0)
stop("Duplicate (i, j) pairs are not allowed.")
class(stm) <- "simple_triplet_matrix"
if(!.Call(R__valid_stm, stm))
stop("failed to create a valid 'simple_triplet_matrix' object")
stm
}
.is_sparse_mat_coercible_to_stm <-
function(x)
UseMethod(".is_sparse_mat_coercible_to_stm")
.is_sparse_mat_coercible_to_stm.simple_triplet_matrix <-
function(x)
TRUE
.is_sparse_mat_coercible_to_stm.default <-
function(x)
FALSE
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)
}
.is_sparse_mat_coercible_to_stm.dgTMatrix <-
.is_sparse_mat_coercible_to_stm.dgCMatrix <-
.is_sparse_mat_coercible_to_stm.dgRMatrix <-
function(x)
TRUE
## 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])
}
.is_sparse_mat_coercible_to_stm.matrix.coo <-
.is_sparse_mat_coercible_to_stm.matrix.csc <-
.is_sparse_mat_coercible_to_stm.matrix.csr <-
function(x)
TRUE
## 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])
}
.is_sparse_mat_coercible_to_stm.spam <-
function(x)
TRUE
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 <- lengths(value)
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(vapply(rnms, is.null, NA))) {
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(vapply(cnms, is.null, NA))) {
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)] <- vapply(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(vapply(args, inherits, NA, "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/R/misc.R 0000644 0001751 0000144 00000000406 12755134131 012505 0 ustar hornik users
##
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/apply.R 0000644 0001751 0000144 00000006720 12262026562 012705 0 ustar hornik users ## 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/crossprod.R 0000644 0001751 0000144 00000010027 14652376256 013606 0 ustar hornik users
## 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)) {
if(!is.simple_triplet_matrix(y) &&
.is_sparse_mat_coercible_to_stm(y))
y <- as.simple_triplet_matrix(y)
.tcrossprod_simple_triplet_matrix(x, y)
}
else if(is.simple_triplet_matrix(y)) {
x <- if(.is_sparse_mat_coercible_to_stm(x))
as.simple_triplet_matrix(x)
else
as.matrix(x)
.tcrossprod_simple_triplet_matrix(y, x, TRUE)
}
else
stop("neither 'x' nor 'y' of class 'simple_triplet_matrix'")
}
crossprod_simple_triplet_matrix <-
function(x, y = NULL) {
if(is.simple_triplet_matrix(x)) {
y <- if(is.null(y))
y
else if(is.simple_triplet_matrix(y))
t(y)
else if(.is_sparse_mat_coercible_to_stm(y))
t(as.simple_triplet_matrix(y))
else
t(as.matrix(y))
.tcrossprod_simple_triplet_matrix(t(x), y)
}
else if(is.simple_triplet_matrix(y)) {
x <- if(.is_sparse_mat_coercible_to_stm(x))
as.simple_triplet_matrix(x)
else
as.matrix(x)
.tcrossprod_simple_triplet_matrix(t(y), t(x), TRUE)
}
else
stop("neither 'x' nor 'y' of class 'simple_triplet_matrix'")
}
matprod_simple_triplet_matrix <-
function(x, y) {
if(is.simple_triplet_matrix(x)) {
y <- if(is.simple_triplet_matrix(y))
y
else if(.is_sparse_mat_coercible_to_stm(y))
as.simple_triplet_matrix(y)
else
as.matrix(y)
.tcrossprod_simple_triplet_matrix(x, t(y))
}
else if(is.simple_triplet_matrix(y)) {
x <- if(.is_sparse_mat_coercible_to_stm(x))
as.simple_triplet_matrix(x)
else
as.matrix(x)
.tcrossprod_simple_triplet_matrix(t(y), x, TRUE)
}
else
stop("neither 'x' nor 'y' of class 'simple_triplet_matrix'")
}
##
matrixOps.simple_triplet_matrix <-
function(x, y)
{
switch(.Generic,
"%*%" = matprod_simple_triplet_matrix(x, y),
"crossprod" = if(missing(y))
crossprod_simple_triplet_matrix(x)
else
crossprod_simple_triplet_matrix(x, y),
"tcrossprod" = if(missing(y))
tcrossprod_simple_triplet_matrix(x)
else
tcrossprod_simple_triplet_matrix(x, y))
}
chooseOpsMethod.simple_triplet_matrix <-
function(x, y, mx, my, cl, reverse)
TRUE
slam/R/subassign.R 0000644 0001751 0000144 00000011075 13435047610 013555 0 ustar hornik users ## CB 2012/9 2016/8
##
## FIXME extending might be useful unless implemented
## as for dense arrays.
##
`[<-.simple_sparse_array` <-
function(x, ..., value) {
if (inherits(value, c("simple_sparse_array", "simple_triplet_matrix"))) {
if (prod(dim(value)) > slam_options("max_dense"))
stop("Replacement disabled.")
value <- as.vector(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(vapply(args, is.numeric, NA)))
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/array.R 0000644 0001751 0000144 00000024433 14162630552 012700 0 ustar hornik users ## 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.
##
if(anyDuplicated(i) > 0)
stop("Duplicate rows in i are not allowed.")
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/foreign.R 0000644 0001751 0000144 00000013646 13036464150 013215 0 ustar hornik users read_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 <- lengths(l)
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.int(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/reduce.R 0000644 0001751 0000144 00000007237 14165526255 013043 0 ustar hornik users ###
## 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
nas <- FALSE
V <- sapply(V, function(x)
if (length(x) > 1L) {
x <- unique(x)
if(length(x) > 1L) {
t <- typeof(x)
if(t == "raw")
stop("cannot reduce multiple entries (missing not defined")
else {
nas <<- TRUE
as.vector(NA, t)
}
} else
x
} else
x,
USE.NAMES = FALSE)
if(nas)
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(base::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(vapply(N, is.null, NA))))
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.int(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/src/ 0000755 0001751 0000144 00000000000 13411716161 012014 5 ustar hornik users slam/src/grouped.c 0000644 0001751 0000144 00000013740 14645757611 013651 0 ustar hornik users #include
#include
#include
extern int _valid_stm(SEXP x);
// ceeboo 2010/8+10, 2016/6, 2024/7
//
// 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) {
SET_VECTOR_ELT(r, 0, (__i = lengthgets(__i, n)));
SET_VECTOR_ELT(r, 1, ( _j = lengthgets( _j, n)));
SET_VECTOR_ELT(r, 2, (__v = lengthgets(__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/dll.c 0000644 0001751 0000144 00000003564 13041567251 012746 0 ustar hornik users
#include
#include
#include
extern SEXP __valid_stm(SEXP x);
extern SEXP __valid_ssa(SEXP x);
extern SEXP __valid_v(SEXP x);
extern SEXP _split_col(SEXP x);
extern SEXP _all_row(SEXP x, SEXP _na_rm);
extern SEXP _part_index(SEXP x);
extern SEXP _vector_index(SEXP d, SEXP x);
extern SEXP _ini_array(SEXP d, SEXP p, SEXP v, SEXP s);
extern SEXP _match_matrix(SEXP x, SEXP y, SEXP _nm);
extern SEXP _unattr(SEXP x);
extern SEXP _sums_stm(SEXP x, SEXP R_dim, SEXP R_na_rm);
extern SEXP _row_tsums(SEXP x, SEXP R_index, SEXP R_na_rm, SEXP R_reduce,
SEXP R_verbose);
extern SEXP tcrossprod_stm_stm(SEXP x, SEXP y, SEXP pkgEnv, SEXP R_verbose);
extern SEXP tcrossprod_stm_matrix(SEXP x, SEXP R_y, SEXP pkgEnv,
SEXP R_verbose, SEXP R_transpose);
extern SEXP _col_apply_stm(SEXP a);
static const R_CallMethodDef CallEntries[] = {
{"R__valid_stm", (DL_FUNC) __valid_stm, 1},
{"R__valid_ssa", (DL_FUNC) __valid_ssa, 1},
{"R__valid_v", (DL_FUNC) __valid_v, 1},
{"R_split_col", (DL_FUNC) _split_col, 1},
{"R_all_row", (DL_FUNC) _all_row, 2},
{"R_part_index", (DL_FUNC) _part_index, 1},
{"R_vector_index", (DL_FUNC) _vector_index, 2},
{"R_ini_array", (DL_FUNC) _ini_array, 4},
{"R_match_matrix", (DL_FUNC) _match_matrix, 3},
{"R_unattr", (DL_FUNC) _unattr, 1},
{"R_sums_stm", (DL_FUNC) _sums_stm, 3},
{"R_row_tsums", (DL_FUNC) _row_tsums, 5},
{"R_tcrossprod_stm_matrix", (DL_FUNC) tcrossprod_stm_matrix, 5},
{"R_tcrossprod_stm_stm", (DL_FUNC) tcrossprod_stm_stm, 4},
{NULL, NULL, 0}
};
static const R_ExternalMethodDef ExternalEntries[] = {
{"R_col_apply_stm", (DL_FUNC) _col_apply_stm, -1},
{NULL, NULL, 0}
};
void R_init_slam(DllInfo *dll)
{
R_registerRoutines(dll, NULL, CallEntries, NULL, ExternalEntries);
R_useDynamicSymbols(dll, FALSE);
}
slam/src/util.c 0000644 0001751 0000144 00000020464 13406203504 013137 0 ustar hornik users #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"), PROTECT(t = allocVector(INTSXP, k)));
UNPROTECT(1);
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.
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(2);
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.c 0000644 0001751 0000144 00000007762 12253526405 013324 0 ustar hornik users
#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/Makevars 0000644 0001751 0000144 00000000041 11321423036 013475 0 ustar hornik users PKG_LIBS = $(BLAS_LIBS) $(FLIBS)
slam/src/sparse.c 0000644 0001751 0000144 00000050142 14645757633 013502 0 ustar hornik users #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 (MAYBE_SHARED(x)) {
SEXP s = x;
SEXP a = PROTECT(ATTRIB(x));
SET_ATTRIB(x, R_NilValue);
x = duplicate(x);
SET_ATTRIB(s, a);
UNPROTECT(1); /* a */
} else
SET_ATTRIB(x, R_NilValue);
if (OBJECT(x))
SET_OBJECT(x, 0);
if (IS_S4_OBJECT(x))
warning("'x' UNSET_S4_OBJECT no longer supported");
// 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"),
PROTECT( CONS(x,
CONS(y,
CONS(ScalarLogical(FALSE),
R_NilValue)))))), pkgEnv);
UNPROTECT(2);
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"),
PROTECT( CONS(x,
CONS(y,
CONS(ScalarLogical(FALSE),
R_NilValue)))))), pkgEnv);
UNPROTECT(2);
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"),
PROTECT( CONS(x,
CONS(y,
CONS((R_transpose && *LOGICAL(R_transpose)) ?
R_transpose : ScalarLogical(FALSE),
R_NilValue)))))), pkgEnv);
UNPROTECT(2);
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(2); /* v, r */
PROTECT(r);
} 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/NAMESPACE 0000644 0001751 0000144 00000012673 14652372271 012465 0 ustar hornik users importFrom("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("aperm", "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")
S3method(".is_sparse_mat_coercible_to_stm", "simple_triplet_matrix")
S3method(".is_sparse_mat_coercible_to_stm", "default")
S3method(".is_sparse_mat_coercible_to_stm", "dgTMatrix")
S3method(".is_sparse_mat_coercible_to_stm", "dgCMatrix")
S3method(".is_sparse_mat_coercible_to_stm", "dgRMatrix")
S3method(".is_sparse_mat_coercible_to_stm", "matrix.coo")
S3method(".is_sparse_mat_coercible_to_stm", "matrix.csr")
S3method(".is_sparse_mat_coercible_to_stm", "matrix.csc")
S3method(".is_sparse_mat_coercible_to_stm", "spam")
## enhanced stuff
useDynLib("slam", .registration = TRUE)
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")
if(getRversion() >= "4.3.0") {
S3method("matrixOps", "simple_triplet_matrix")
S3method("chooseOpsMethod", "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("aperm", "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")
## 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/inst/ 0000755 0001751 0000144 00000000000 13143661650 012206 5 ustar hornik users slam/inst/po/ 0000755 0001751 0000144 00000000000 13143661650 012624 5 ustar hornik users slam/inst/po/en@quot/ 0000755 0001751 0000144 00000000000 13143661650 014237 5 ustar hornik users slam/inst/po/en@quot/LC_MESSAGES/ 0000755 0001751 0000144 00000000000 13143661650 016024 5 ustar hornik users slam/inst/po/en@quot/LC_MESSAGES/R-slam.mo 0000644 0001751 0000144 00000016230 13143661650 017516 0 ustar hornik users Þ• K t e Ì ` a v ž ½ Ï ï & ' E & m ) ” ¾ & Ú , 8 . g „ * ¢ Í ç : L \ q 6 5 × "
, 0
]
~
–
. ·
æ
/ 6 2 5 i Ÿ * ° ' Û 5 2 9 5 l ) ¢ ' Ì ô
( #
L
- m
$ ›
& À
) ç
" 5 4 7 j ¢ Á ß õ 5 & ( \ B … . È , ÷ $ < X / p 6 ä ý & - T # j Ž ¥ . Å + ô * - K y & • , ¼ 8 é " ? . ] Œ ¦ ¿ ß ù 0 L 6 _ 5 – " Ì , ï = U . v ¥ / Á 6 ñ 5 ( ^ * o ' š 5  2 ø 5 + ) a ' ‹ ³ É , â - 0 ( ^ . ‡ - ¶ " ä 9 ; A } œ º # Ð ô 5 ( ; B d . § 0 Ö ; 7 S ‹ 3 4 C J A / * $ F 2 : 1 E " I - H ) B % & = . # + 0 @ K G 9
' 8 D > < ? 5 ; , ! ( 6 7
'DROP' not supported 'INDEX' invalid length 'MARGIN' invalid 'MARGINS' and/or 'DIM' invalid 'MARGINS' invalid 'dim' must have positive length 'f' invalid length 'transpose' not implemented 'x' not of class 'simple_sparse_array' 'x' not of class simple_striplet_matrix 'x' not of class simple_triplet_matrix 'x, y' not of class simple_triplet_matrix A %s simple triplet matrix. A simple sparse array of dimension %s. Cannot mix positive and negative subscripts. Character vector subscripting currently not implemented. Empty subscripting disabled. Extending is not implemented. Generic '%s' not defined for "%s" objects. INDEX [%s] invalid length Incompatible dimensions. Incorrect number of dimensions. Invalid component length. Invalid dimnames. Invalid margin. Invalid permutation. Invalid subscript type: %s. Invalid subscript. Logical vector subscripting currently not implemented. Logical vector subscripting disabled for this object. MARGINS [%s] invalid factorization Missing dimensions disabled for this object. NA indices currently not allowed NA indices not allowed. NA/NaN handling not implemented. NAs are not allowed in subscripted assignments NAs introduced by reduction Negative subscripting disabled for this object. Negative vector subscripting disabled for this object. Negative vector subsripting disabled for this object. Not implemented. Numbers of columns of matrices must match. Numbers of rows of matrices must match. Numeric vector subscripting disabled for this object. Only numeric / matrix subscripting is implemented. Only numeric multi-index subscripting is implemented. Only numeric subscripting is implemented. Repeated indices currently not allowed. Replacement disabled. Subscript out of bounds. Unary '%s' not defined for "%s" objects. Unsupported number of dimensions Vector subscripting disabled for this object. common parts of 'dim' do not conform component 'v' contains 'ZERO' value(s) definitions of ZERO of 'v' do not conform dim(x) must have a positive length failed to create a valid 'simple_sparse_array' object failed to create a valid 'simple_triplet_matrix' object incorrect number of dimensions invalid dim replacement value invalid matrix format lengths of 'dim' do not conform multiple entries negative values are not allowed in a matrix subscript number of cells %d too large for hashing number of items to replace is not a multiple of replacement length only 0's may be mixed with negative subscripts oops, invalid 'simple_triplet_matrix' object processing %d cells ... replacement has length zero subscript out of bounds the numer of rows of 'x' and 'y' do not conform zero entries Project-Id-Version: slam 0.1-41
POT-Creation-Date: 2017-08-12 22:23
PO-Revision-Date: 2017-08-12 22:23
Last-Translator: Automatically generated
Language-Team: none
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Language: en
Plural-Forms: nplurals=2; plural=(n != 1);
‘DROP’ not supported ‘INDEX’ invalid length ‘MARGIN’ invalid ‘MARGINS’ and/or ‘DIM’ invalid ‘MARGINS’ invalid ‘dim’ must have positive length ‘f’ invalid length ‘transpose’ not implemented ‘x’ not of class ‘simple_sparse_array’ ‘x’ not of class simple_striplet_matrix ‘x’ not of class simple_triplet_matrix ‘x, y’ not of class simple_triplet_matrix A %s simple triplet matrix. A simple sparse array of dimension %s. Cannot mix positive and negative subscripts. Character vector subscripting currently not implemented. Empty subscripting disabled. Extending is not implemented. Generic ‘%s’ not defined for "%s" objects. INDEX [%s] invalid length Incompatible dimensions. Incorrect number of dimensions. Invalid component length. Invalid dimnames. Invalid margin. Invalid permutation. Invalid subscript type: %s. Invalid subscript. Logical vector subscripting currently not implemented. Logical vector subscripting disabled for this object. MARGINS [%s] invalid factorization Missing dimensions disabled for this object. NA indices currently not allowed NA indices not allowed. NA/NaN handling not implemented. NAs are not allowed in subscripted assignments NAs introduced by reduction Negative subscripting disabled for this object. Negative vector subscripting disabled for this object. Negative vector subsripting disabled for this object. Not implemented. Numbers of columns of matrices must match. Numbers of rows of matrices must match. Numeric vector subscripting disabled for this object. Only numeric / matrix subscripting is implemented. Only numeric multi-index subscripting is implemented. Only numeric subscripting is implemented. Repeated indices currently not allowed. Replacement disabled. Subscript out of bounds. Unary ‘%s’ not defined for "%s" objects. Unsupported number of dimensions Vector subscripting disabled for this object. common parts of ‘dim’ do not conform component ‘v’ contains ‘ZERO’ value(s) definitions of ZERO of ‘v’ do not conform dim(x) must have a positive length failed to create a valid ‘simple_sparse_array’ object failed to create a valid ‘simple_triplet_matrix’ object incorrect number of dimensions invalid dim replacement value invalid matrix format lengths of ‘dim’ do not conform multiple entries negative values are not allowed in a matrix subscript number of cells %d too large for hashing number of items to replace is not a multiple of replacement length only 0's may be mixed with negative subscripts oops, invalid ‘simple_triplet_matrix’ object processing %d cells ... replacement has length zero subscript out of bounds the numer of rows of ‘x’ and ‘y’ do not conform zero entries slam/man/ 0000755 0001751 0000144 00000000000 14652376275 012020 5 ustar hornik users slam/man/crossprod.Rd 0000644 0001751 0000144 00000002564 12254246630 014317 0 ustar hornik users \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/options.Rd 0000644 0001751 0000144 00000001575 12755134131 013773 0 ustar hornik users \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/norms.Rd 0000644 0001751 0000144 00000001040 12220373656 013425 0 ustar hornik users \name{norms}
\alias{row_norms}
\alias{col_norms}
\title{Row and Column Norms}
\description{
Compute row and column \eqn{p}-norms.
}
\usage{
row_norms(x, p = 2)
col_norms(x, p = 2)
}
\arguments{
\item{x}{a sparse \code{\link{simple_triplet_matrix}}, or a dense
matrix.}
\item{p}{a numeric at least one. Using \code{Inf} gives the maximum
norm.}
}
\value{
A vector with the row or column \eqn{p}-norms for the given matrix.
}
\examples{
x <- matrix(1 : 9, 3L)
## Row lengths:
row_norms(x)
## Column maxima:
col_norms(x, Inf)
}
slam/man/array.Rd 0000644 0001751 0000144 00000006337 12755134131 013417 0 ustar hornik users \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.Rd 0000644 0001751 0000144 00000003562 11753474631 013364 0 ustar hornik users \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/rollup.Rd 0000644 0001751 0000144 00000007135 12731673472 013625 0 ustar hornik users \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}
slam/man/foreign.Rd 0000644 0001751 0000144 00000004315 14645760027 013735 0 ustar hornik users \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{https://www-users.cse.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{https://www.cs.utexas.edu/~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/apply.Rd 0000644 0001751 0000144 00000003674 12262026562 013430 0 ustar hornik users \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.Rd 0000644 0001751 0000144 00000003651 11314343030 013252 0 ustar hornik users \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/matrix.Rd 0000644 0001751 0000144 00000005417 13060450067 013602 0 ustar hornik users \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(s, t(s)), rbind(s, s))
\dontrun{
## map to default Matrix class
stopifnot(require("Matrix"))
sparseMatrix(i = s$i, j = s$j, x = s$v, dims = dim(s),
dimnames = dimnames(s))
}
}
\keyword{math}
slam/DESCRIPTION 0000644 0001751 0000144 00000001570 14652414325 012743 0 ustar hornik users Package: slam
Version: 0.1-52
Title: Sparse Lightweight Arrays and Matrices
Authors@R: c(person("Kurt", "Hornik", role = c("aut", "cre"),
email = "Kurt.Hornik@R-project.org",
comment = c(ORCID = "0000-0003-4198-9911")),
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.4.0)
Imports: stats
Enhances: Matrix, SparseM, spam
License: GPL-2
NeedsCompilation: yes
Packaged: 2024-07-31 08:58:37 UTC; hornik
Author: Kurt Hornik [aut, cre] (),
David Meyer [aut],
Christian Buchta [aut]
Maintainer: Kurt Hornik
Repository: CRAN
Date/Publication: 2024-07-31 10:58:29 UTC