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
27
28
29
|
## Generate sparse multidimensional Gaussian quadrature grids ---> ../man/GQdk.Rd
## Unused currently; rather GHrule() --> ./GHrule.R
GQdk <- function(d=1L, k=1L) {
stopifnot(0L < (d <- as.integer(d)[1]),
d <= 20L,
0L < (k <- as.integer(k)[1]),
k <= length(GQNd <- GQN[[d]]))## -> GQN, stored in ./sysdata.rda
tmat <- t(GQNd[[k]])
##rperms<- combinat::permn(seq_len(d) + 1L, function(v) c(1L,v))
## rperms <- lapply(.Call(allPerm_int, seq_len(d) + 1L), function(v) c(1L, v))
perms <- tryCatch (
.Call(allPerm_int, seq_len(d) + 1L, as.integer(factorial(d))),
warning = function (w) w,
error = function (e) e)
if (methods::is(perms, "error") | methods::is(perms, "warning"))
stop("Can not allocate a vector that large")
rperms <- lapply(perms, function(v) c(1L, v))
dd <- unname(as.matrix(do.call(expand.grid, c(rep.int(list(c(-1,1)), d), KEEP.OUT.ATTRS=FALSE))))
#unname(unique(t(do.call(cbind,
# lapply(as.data.frame(t(cbind(1, dd))),
# "*", e2=do.call(cbind, lapply(rperms, function(ind) tmat[ind,])))))))
e2 <- do.call(cbind, lapply(rperms, function(ind) tmat[ind,]))
ddf <- as.data.frame(t(cbind(1,dd)))
res <- NULL
for (i in 1:ncol(ddf))
res <- unique(rbind(res, t(ddf[, i] * e2)))
return(res)
}
|
