lhs/0000755000176200001440000000000013425544676011060 5ustar liggesuserslhs/inst/0000755000176200001440000000000013425401600012010 5ustar liggesuserslhs/inst/doc/0000755000176200001440000000000013425401600012555 5ustar liggesuserslhs/inst/doc/lhs_faq.Rmd0000644000176200001440000002377213420502241014647 0ustar liggesusers--- title: "Latin Hypercube Samples - Questions" author: "Rob Carnell" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Latin Hypercube Samples - Questions} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) require(lhs) ``` ## Question 1 I am looking for a package which gives me latin hyper cube samples from a grid of values: ```{r q1} a <- (1:10) b <- (20:30) dataGrid <- expand.grid(a, b) ``` ### Answer The `lhs` package returns a uniformly distributed stratified sample from the unit hypercube. The marginal distributions can then be transformed to your distribution of choice. If you wanted a uniform Latin hypercube on [1,10] and [20,30] with 22 samples, you could do: ```{r a1} X <- randomLHS(22, 2) X[,1] <- 1 + 9*X[,1] X[,2] <- 20 + 10*X[,2] # OR Y <- randomLHS(22, 2) Y[,1] <- qunif(Y[,1], 1, 9) Y[,2] <- qunif(Y[,2], 20, 30) head(X) head(Y) ``` If you want integers only in the sample, then we must be careful about what we mean by a Latin hypercube sample. If you wanted exactly 3 points, then you could divide up the range [1,10] into three almost equal parts and sample from `1:3`, `4:6`, and `7:10`. The problem is that it wouldn't be uniform sample across the range. (7 would be sampled less often than 2 for example) To do a Latin hypercube sample on the intgers, you should have a number of integers on the margins which have the number of points sampled as a common factor. For example if you sample 3 points from `1:9`, and `21:32` then you could sample as follows: ```{r a12} a <- c(sample(1:3,1), sample(4:6, 1), sample(7:9, 1)) b <- c(sample(21:24,1), sample(25:28, 1), sample(29:32,1)) ``` and then randomly permute the entries of `a` and `b`. Or more generally, take `n` samples from the list of integer groups: ```{r a13} integerLHS <- function(n, intGroups) { stopifnot(all(lapply(intGroups, function(X) length(X) %% n) == 0)) stopifnot(require(lhs)) stopifnot(is.list(intGroups)) ranges <- lapply(intGroups, function(X) max(X) - min(X)) A <- matrix(nrow = n, ncol = length(intGroups)) for (j in 1:length(ranges)) { sequ <- order(runif(n)) if (length(intGroups[[1]]) > 1) { spacing <- intGroups[[j]][2] - intGroups[[j]][1] } else stop("must have more than 1 intGroup") for (k in 1:n) { i <- sequ[k] a <- min(intGroups[[j]]) + (i - 1)*(ranges[[j]] + spacing)/n b <- min(intGroups[[j]]) + i*(ranges[[j]] + spacing)/n - 1 if (a < b) { A[k,j] <- sample(seq(a,b,spacing), 1) } else if (a == b) { A[k,j] <- a } else stop("error") } } return(A) } integerLHS(10, list(1:10, 31:40)) integerLHS(5, list(1:10, 31:40)) integerLHS(2, list(1:10, 31:40)) integerLHS(5, list(1:20, 31:60, 101:115)) integerLHS(5, list(seq(2,20,2), 31:60, 101:115)) ``` ## Question 2 I am trying to do a Latin Hypercube Sampling (LHS) to a 5-parameter design matrix. I want the combination of the first three parameters to sum up to 1 (which obviously do not) If I divide each of these parameters with the sum, the uniform distribution is lost. Is there a way to maintain the random LHS (with uniformly distributed parameters) so that the refered condition is fulfilled? ### Answer In my experience with Latin hypercube samples, most people draw the sample on a uniform hypercube and then transform the uniform cube to have new distributions on the margins. The transformed distributions are not necessarily uniform. It is possible to draw a Latin hypercube with correlated margins and I hope to add that to my package in the future. I have also done transforms such that the transformed marginal distributions are correlated (as you have in your example). I have not seen a correlated set of uniform marginal distributions such that the margins sum to one, however. I'll make a quick example argument that explains the difficulty... In two dimensions, you could draw this which is uniform and correlated. ```{r a21} x <- seq(0.05, 0.95, length = 10) y <- 1 - x all.equal(x + y, rep(1, length(x))) hist(x, main = "") hist(y, main = "") ``` But in three dimensions, it is hard to maintain uniformity because large samples on the first uniform margin overweight the small samples on the other margins. ```{r a22} x <- seq(0.05, 0.95, length = 10) y <- runif(length(x), 0, 1 - x) z <- 1 - x - y hist(x, main = "") hist(y, main = "") hist(z, main = "") ``` The commmon practice in your situation is draw the `K` parameters together as a uniform Latin hypercube on `0-1` and then transform the margins of the hypercube to the desired distributions. Easy Example * Parameter 1: normal(1, 2) * Parameter 2: normal(3, 4) * Parameter 3: uniform(5, 10) ```{r a3, fig.width=5, fig.height=5} N <- 1000 x <- randomLHS(N, 3) y <- x y[,1] <- qnorm(x[,1], 1, 2) y[,2] <- qnorm(x[,2], 3, 4) y[,3] <- qunif(x[,3], 5, 10) par(mfrow = c(2,2)) dummy <- apply(x, 2, hist, main = "") par(mfrow = c(2,2)) dummy <- apply(y, 2, hist, main = "") ``` The transformed distributions maintain their "Latin" properties, but are in the form of new distributions. In your case, you'd like the first three columns to be transformed into a correlated set that sums to one. Still follow the pattern... ```{r a24, fig.width=5, fig.height=5} x <- randomLHS(N, 5) y <- x y[,1] <- x[,1]/rowSums(x[,1:3]) y[,2] <- x[,2]/rowSums(x[,1:3]) y[,3] <- x[,3]/rowSums(x[,1:3]) y[,4] <- x[,4] y[,5] <- x[,5] par(mfrow = c(2,3)) dummy <- apply(x, 2, hist, main = "") par(mfrow = c(2,3)) dummy <- apply(y, 2, hist, main = "") all.equal(rowSums(y[,1:3]), rep(1, nrow(y))) ``` The uniform properties are gone as you can see here... ```{r a25} par(mfrow = c(1,1)) pairs(x) pairs(y, col = "red") ``` But, the "Latin" properties of the first three margins are maintained as in this smaller example... ```{r a26} N <- 10 x <- randomLHS(N, 5) y <- x y[,1] <- x[,1]/rowSums(x[,1:3]) y[,2] <- x[,2]/rowSums(x[,1:3]) y[,3] <- x[,3]/rowSums(x[,1:3]) y[,4] <- x[,4] y[,5] <- x[,5] pairs(x) pairs(y, col = "red") ``` ## Question 3 How do I create a Latin hypercube that ranges between between 0 and 1 and sums to 1? ### Answer I have an imperfect solution to this problem using a Dirichlet distribution. The Dirichlet seems to keep the range of the values larger once they are normalized. The result is not uniformly distributed on (0,1) anymore, but instead is Dirichlet distributed with the parameters alpha. The Latin properties are maintained. ```{r qdirichlet} qdirichlet <- function(X, alpha) { # qdirichlet is not an exact quantile function since the quantile of a # multivariate distribtion is not unique # qdirichlet is also not the quantiles of the marginal distributions since # those quantiles do not sum to one # qdirichlet is the quantile of the underlying gamma functions, normalized # This has been tested to show that qdirichlet approximates the dirichlet # distribution well and creates the correct marginal means and variances # when using a latin hypercube sample lena <- length(alpha) stopifnot(is.matrix(X)) sims <- dim(X)[1] stopifnot(dim(X)[2] == lena) if (any(is.na(alpha)) || any(is.na(X))) stop("NA values not allowed in qdirichlet") Y <- matrix(0, nrow = sims, ncol = lena) ind <- which(alpha != 0) for (i in ind) { Y[,i] <- qgamma(X[,i], alpha[i], 1) } Y <- Y / rowSums(Y) return(Y) } X <- randomLHS(1000, 7) Y <- qdirichlet(X, rep(1,7)) stopifnot(all(abs(rowSums(Y) - 1) < 1E-12)) range(Y) ws <- randomLHS(1000, 7) wsSums <- rowSums(ws) wss <- ws / wsSums stopifnot(all(abs(rowSums(wss) - 1) < 1E-12)) range(wss) ``` ## Question 5 I need to use Latin hypercube sampling for my own custome functions. ### Answer ```{r custom, fig.width=5, fig.height=5} require(lhs) # functions you described T1 <- function(t) t*t WL1 <- function(T1, t) T1*t BE1 <- function(WL1, T1, t) WL1*T1*t # t is distributed according to some pdf (e.g. normal) # draw a lhs with 512 rows and 3 columns (one for each function) y <- randomLHS(512, 3) # transform the three columns to a normal distribution (these could be any # distribution) t <- apply(y, 2, function(columny) qnorm(columny, 2, 1)) # transform t using the functions provided result <- cbind( T1(t[,1]), WL1(T1(t[,2]), t[,2]), BE1(WL1(T1(t[,3]), t[,3]), T1(t[,3]), t[,3]) ) # check the results # these should be approximately uniform par(mfrow = c(2,2)) dummy <- apply(y, 2, hist, breaks = 50, main = "") # these should be approximately normal par(mfrow = c(2,2)) dummy <- apply(t, 2, hist, breaks = 50, main = "") # these should be the results of the functions par(mfrow = c(2,2)) dummy <- apply(result, 2, hist, breaks = 50, main = "") ``` ## Question 6 I need a Latin hypercube sample on an integer set or a set of colors. ### Answer ```{r q6, fig.height=5, fig.width=5} N <- 1000 set.seed(1919) x <- randomLHS(N, 4) y <- x # uniform on 1-10 y[,1] <- ceiling(qunif(x[,1], 0, 10)) # three colors 1,2,3 y[,2] <- ceiling(qunif(x[,2], 0, 3)) # other distributions y[,3] <- qunif(x[,3], 5, 10) y[,4] <- qnorm(x[,4], 0, 2) par(mfrow=c(2,2)) dummy <- apply(x, 2, hist, main="") par(mfrow=c(2,2)) plot(1:10, c(table(y[,1])), type="h", col="blue", lwd=2, ylim=c(0,120), ylab="Frequency", xlab="y[,1]") plot(1:3, c(table(y[,2])), type="h", col="blue", lwd=2, ylim=c(0,400), ylab="Frequency", xlab="y[,2]") hist(y[,3], main="") hist(y[,4], main="") # change to color names z <- as.data.frame(y) z[,2] <- factor(y[,2], labels=c("R","G","B")) z[1:10,] ``` lhs/inst/doc/lhs_basics.R0000644000176200001440000001174313425401576015034 0ustar liggesusers## ----setup, include = FALSE---------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) require(lhs) source("VignetteCommonCode.R") graph2dLHS <- function(Alhs) { stopifnot(ncol(Alhs) == 2) sims <- nrow(Alhs) par(mar = c(4,4,2,2)) plot.default(Alhs[,1], Alhs[,2], type = "n", ylim = c(0,1), xlim = c(0,1), xlab = "Parameter 1", ylab = "Parameter 2", xaxs = "i", yaxs = "i", main = "") for (i in 1:nrow(Alhs)) { rect(floor(Alhs[i,1]*sims)/sims, floor(Alhs[i,2]*sims)/sims, ceiling(Alhs[i,1]*sims)/sims, ceiling(Alhs[i,2]*sims)/sims, col = "grey") } points(Alhs[,1], Alhs[,2], pch = 19, col = "red") abline(v = (0:sims)/sims, h = (0:sims)/sims) } # transform is a function of the kind that takes a number # transform <- function(x){return(qnorm(x,mean=0, std=1))} graph2dLHSTransform <- function(Alhs, transform1, transform2, min1, max1, min2, max2) { stopifnot(ncol(Alhs) == 2) stopifnot(all(Alhs[,1] <= max1 && Alhs[,1] >= min1)) stopifnot(all(Alhs[,2] <= max2 && Alhs[,2] >= min2)) sims <- nrow(Alhs) breaks <- seq(0,1,length = sims + 1)[2:(sims)] breaksTransformed1 <- sapply(breaks, transform1) breaksTransformed2 <- sapply(breaks, transform2) par(mar = c(4,4,2,2)) plot.default(Alhs[,1], Alhs[,2], type = "n", ylim = c(min2, max2), xlim = c(min1, max1), xlab = "Parameter 1", ylab = "Parameter 2", xaxs = "i", yaxs = "i", main = "") for (si in 1:sims) { temp <- Alhs[si,] for (i in 1:sims) { if ((i == 1 && min1 <= temp[1] && breaksTransformed1[i] >= temp[1]) || (i == sims && max1 >= temp[1] && breaksTransformed1[i - 1] <= temp[1]) || (breaksTransformed1[i - 1] <= temp[1] && breaksTransformed1[i] >= temp[1])) { for (j in 1:sims) { if ((j == 1 && min2 <= temp[2] && breaksTransformed2[j] >= temp[2]) || (j == sims && max2 >= temp[2] && breaksTransformed2[j - 1] <= temp[2]) || (breaksTransformed2[j - 1] <= temp[2] && breaksTransformed2[j] >= temp[2])) { if (i == 1) { xbot <- min1 xtop <- breaksTransformed1[i] } else if (i == sims) { xbot <- breaksTransformed1[i - 1] xtop <- max1 } else { xbot <- breaksTransformed1[i - 1] xtop <- breaksTransformed1[i] } if (j == 1) { ybot <- min2 ytop <- breaksTransformed2[j] } else if (j == sims) { ybot <- breaksTransformed2[j - 1] ytop <- max2 } else { ybot <- breaksTransformed2[j - 1] ytop <- breaksTransformed2[j] } rect(xbot, ybot, xtop, ytop, col = "grey") } } } } } points(Alhs[,1], Alhs[,2], pch = 19, col = "red") abline(v = breaksTransformed1, h = breaksTransformed2) } #set.seed(1111) #A <- randomLHS(5,4) #f <- function(x){qnorm(x)} #g <- function(x){qlnorm(x, meanlog=0.5, sdlog=1)} #B <- A #B[,1] <- f(A[,1]) #B[,2] <- g(A[,2]) #graph2dLHSTransform(B[,1:2], f, g, -4, 4, 0, 8) #f <- function(x){qunif(x, 3, 5)} #B <- apply(A, 2, f) #graph2dLHSTransform(B[,1:2], f) ## ----block1-------------------------------------------------------------- # set the seed for reproducibility set.seed(1111) # a design with 5 samples from 4 parameters A <- randomLHS(5, 4) A ## ----figureX, fig.align='center', fig.height=5, fig.width=5, echo=FALSE---- graph2dLHS(A[,1:2]) ## ----block 3------------------------------------------------------------- B <- matrix(nrow = nrow(A), ncol = ncol(A)) B[,1] <- qnorm(A[,1], mean = 0, sd = 1) B[,2] <- qlnorm(A[,2], meanlog = 0.5, sdlog = 1) B[,3] <- A[,3] B[,4] <- qunif(A[,4], min = 7, max = 10) B ## ----figureY, fig.align='center', fig.height=5, fig.width=5, echo=FALSE---- f <- function(x){qnorm(x)} g <- function(x){qlnorm(x, meanlog = 0.5, sdlog = 1)} graph2dLHSTransform(B[,1:2], f, g, -4, 4, 0, 8) ## ----block 4------------------------------------------------------------- set.seed(101) A <- randomLHS(30, 10) A1 <- optimumLHS(30, 10, maxSweeps = 4, eps = 0.01) A2 <- maximinLHS(30, 10, dup = 5) A3 <- improvedLHS(30, 10, dup = 5) A4 <- geneticLHS(30, 10, pop = 1000, gen = 8, pMut = 0.1, criterium = "S") A5 <- geneticLHS(30, 10, pop = 1000, gen = 8, pMut = 0.1, criterium = "Maximin") ## ----Z, fig.align='center', fig.height=7, fig.width=7, echo=FALSE-------- pairs(A, pch = 19, col = "blue", cex = 0.5) ## ----W, fig.align='center', fig.height=7, fig.width=7, echo=FALSE-------- pairs(A1, pch = 19, col = "blue", cex = 0.5) ## ----G, fig.align='center', fig.height=7, fig.width=7, echo=FALSE-------- pairs(A2, pch = 19, col = "blue", cex = 0.5) lhs/inst/doc/lhs_faq.R0000644000176200001440000001507713425401600014327 0ustar liggesusers## ----setup, include = FALSE---------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) require(lhs) ## ----q1------------------------------------------------------------------ a <- (1:10) b <- (20:30) dataGrid <- expand.grid(a, b) ## ----a1------------------------------------------------------------------ X <- randomLHS(22, 2) X[,1] <- 1 + 9*X[,1] X[,2] <- 20 + 10*X[,2] # OR Y <- randomLHS(22, 2) Y[,1] <- qunif(Y[,1], 1, 9) Y[,2] <- qunif(Y[,2], 20, 30) head(X) head(Y) ## ----a12----------------------------------------------------------------- a <- c(sample(1:3,1), sample(4:6, 1), sample(7:9, 1)) b <- c(sample(21:24,1), sample(25:28, 1), sample(29:32,1)) ## ----a13----------------------------------------------------------------- integerLHS <- function(n, intGroups) { stopifnot(all(lapply(intGroups, function(X) length(X) %% n) == 0)) stopifnot(require(lhs)) stopifnot(is.list(intGroups)) ranges <- lapply(intGroups, function(X) max(X) - min(X)) A <- matrix(nrow = n, ncol = length(intGroups)) for (j in 1:length(ranges)) { sequ <- order(runif(n)) if (length(intGroups[[1]]) > 1) { spacing <- intGroups[[j]][2] - intGroups[[j]][1] } else stop("must have more than 1 intGroup") for (k in 1:n) { i <- sequ[k] a <- min(intGroups[[j]]) + (i - 1)*(ranges[[j]] + spacing)/n b <- min(intGroups[[j]]) + i*(ranges[[j]] + spacing)/n - 1 if (a < b) { A[k,j] <- sample(seq(a,b,spacing), 1) } else if (a == b) { A[k,j] <- a } else stop("error") } } return(A) } integerLHS(10, list(1:10, 31:40)) integerLHS(5, list(1:10, 31:40)) integerLHS(2, list(1:10, 31:40)) integerLHS(5, list(1:20, 31:60, 101:115)) integerLHS(5, list(seq(2,20,2), 31:60, 101:115)) ## ----a21----------------------------------------------------------------- x <- seq(0.05, 0.95, length = 10) y <- 1 - x all.equal(x + y, rep(1, length(x))) hist(x, main = "") hist(y, main = "") ## ----a22----------------------------------------------------------------- x <- seq(0.05, 0.95, length = 10) y <- runif(length(x), 0, 1 - x) z <- 1 - x - y hist(x, main = "") hist(y, main = "") hist(z, main = "") ## ----a3, fig.width=5, fig.height=5--------------------------------------- N <- 1000 x <- randomLHS(N, 3) y <- x y[,1] <- qnorm(x[,1], 1, 2) y[,2] <- qnorm(x[,2], 3, 4) y[,3] <- qunif(x[,3], 5, 10) par(mfrow = c(2,2)) dummy <- apply(x, 2, hist, main = "") par(mfrow = c(2,2)) dummy <- apply(y, 2, hist, main = "") ## ----a24, fig.width=5, fig.height=5-------------------------------------- x <- randomLHS(N, 5) y <- x y[,1] <- x[,1]/rowSums(x[,1:3]) y[,2] <- x[,2]/rowSums(x[,1:3]) y[,3] <- x[,3]/rowSums(x[,1:3]) y[,4] <- x[,4] y[,5] <- x[,5] par(mfrow = c(2,3)) dummy <- apply(x, 2, hist, main = "") par(mfrow = c(2,3)) dummy <- apply(y, 2, hist, main = "") all.equal(rowSums(y[,1:3]), rep(1, nrow(y))) ## ----a25----------------------------------------------------------------- par(mfrow = c(1,1)) pairs(x) pairs(y, col = "red") ## ----a26----------------------------------------------------------------- N <- 10 x <- randomLHS(N, 5) y <- x y[,1] <- x[,1]/rowSums(x[,1:3]) y[,2] <- x[,2]/rowSums(x[,1:3]) y[,3] <- x[,3]/rowSums(x[,1:3]) y[,4] <- x[,4] y[,5] <- x[,5] pairs(x) pairs(y, col = "red") ## ----qdirichlet---------------------------------------------------------- qdirichlet <- function(X, alpha) { # qdirichlet is not an exact quantile function since the quantile of a # multivariate distribtion is not unique # qdirichlet is also not the quantiles of the marginal distributions since # those quantiles do not sum to one # qdirichlet is the quantile of the underlying gamma functions, normalized # This has been tested to show that qdirichlet approximates the dirichlet # distribution well and creates the correct marginal means and variances # when using a latin hypercube sample lena <- length(alpha) stopifnot(is.matrix(X)) sims <- dim(X)[1] stopifnot(dim(X)[2] == lena) if (any(is.na(alpha)) || any(is.na(X))) stop("NA values not allowed in qdirichlet") Y <- matrix(0, nrow = sims, ncol = lena) ind <- which(alpha != 0) for (i in ind) { Y[,i] <- qgamma(X[,i], alpha[i], 1) } Y <- Y / rowSums(Y) return(Y) } X <- randomLHS(1000, 7) Y <- qdirichlet(X, rep(1,7)) stopifnot(all(abs(rowSums(Y) - 1) < 1E-12)) range(Y) ws <- randomLHS(1000, 7) wsSums <- rowSums(ws) wss <- ws / wsSums stopifnot(all(abs(rowSums(wss) - 1) < 1E-12)) range(wss) ## ----custom, fig.width=5, fig.height=5----------------------------------- require(lhs) # functions you described T1 <- function(t) t*t WL1 <- function(T1, t) T1*t BE1 <- function(WL1, T1, t) WL1*T1*t # t is distributed according to some pdf (e.g. normal) # draw a lhs with 512 rows and 3 columns (one for each function) y <- randomLHS(512, 3) # transform the three columns to a normal distribution (these could be any # distribution) t <- apply(y, 2, function(columny) qnorm(columny, 2, 1)) # transform t using the functions provided result <- cbind( T1(t[,1]), WL1(T1(t[,2]), t[,2]), BE1(WL1(T1(t[,3]), t[,3]), T1(t[,3]), t[,3]) ) # check the results # these should be approximately uniform par(mfrow = c(2,2)) dummy <- apply(y, 2, hist, breaks = 50, main = "") # these should be approximately normal par(mfrow = c(2,2)) dummy <- apply(t, 2, hist, breaks = 50, main = "") # these should be the results of the functions par(mfrow = c(2,2)) dummy <- apply(result, 2, hist, breaks = 50, main = "") ## ----q6, fig.height=5, fig.width=5--------------------------------------- N <- 1000 set.seed(1919) x <- randomLHS(N, 4) y <- x # uniform on 1-10 y[,1] <- ceiling(qunif(x[,1], 0, 10)) # three colors 1,2,3 y[,2] <- ceiling(qunif(x[,2], 0, 3)) # other distributions y[,3] <- qunif(x[,3], 5, 10) y[,4] <- qnorm(x[,4], 0, 2) par(mfrow=c(2,2)) dummy <- apply(x, 2, hist, main="") par(mfrow=c(2,2)) plot(1:10, c(table(y[,1])), type="h", col="blue", lwd=2, ylim=c(0,120), ylab="Frequency", xlab="y[,1]") plot(1:3, c(table(y[,2])), type="h", col="blue", lwd=2, ylim=c(0,400), ylab="Frequency", xlab="y[,2]") hist(y[,3], main="") hist(y[,4], main="") # change to color names z <- as.data.frame(y) z[,2] <- factor(y[,2], labels=c("R","G","B")) z[1:10,] lhs/inst/doc/augment_lhs.Rmd0000644000176200001440000001442713416532121015542 0ustar liggesusers--- title: "An Example of Augmenting a Latin Hypercube" author: "Rob Carnell" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{An Example of Augmenting a Latin Hypercube} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} %\VignetteAuthor{Rob Carnell} %\VignetteKeyword{lhs} %\VignetteKeyword{latin hypercube} %\VignetteKeyword{augment} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) source("VignetteCommonCode.R") require(lhs) graph2DaugmentLHS1 <- function(sims, extras) { A <- randomLHS(sims, 2) B <- augmentLHS(A, extras) plot.default(A[,1], A[,2], type = "n", ylim = c(0,1), xlim = c(0,1), xlab = "x1", ylab = "x2", xaxs = "i", yaxs = "i", main = "") for (i in 1:length(A[,1])) { rect(floor(A[i,1]*sims)/sims, floor(A[i,2]*sims)/sims, ceiling(A[i,1]*sims)/sims, ceiling(A[i,2]*sims)/sims, col = "grey") } points(A[,1], A[,2], pch = 19, col = "red") abline(v = (0:sims)/sims, h = (0:sims)/sims) return(list(A = A, B = B, sims = sims, extras = extras)) } graph2DaugmentLHS2 <- function(X) { A <- X$A B <- X$B sims <- X$sims extras <- X$extras plot.default(A[,1], A[,2], type = "n", ylim = c(0,1), xlim = c(0,1), xlab = "x1", ylab = "x2", xaxs = "i", yaxs = "i", main = "") N <- sims + extras for (i in 1:length(B[,1])) { rect(floor(B[i,1]*N)/N, floor(B[i,2]*N)/N, ceiling(B[i,1]*N)/N, ceiling(B[i,2]*N)/N, col = "grey") } points(A[,1], A[,2], pch = 19, col = "red") points(B[((sims + 1):(sims + extras)), 1], B[((sims + 1):(sims + extras)), 2], pch = 19, col = "blue") abline(v = (0:N)/N, h = (0:N)/N) } # X <- graph2DaugmentLHS1(5,5) # graph2DaugmentLHS2(X) ``` Suppose that a computer simulation study is being designed that requires expensive runs. A Latin hypercube design is desired for this simulation so that the expectation of the simulation output can be estimated efficiently given the distributions of the input variables. Latin hypercubes are most often used in highly dimensional problems, but the example shown is of small dimension. Suppose further that the total extent of funding is uncertain. Enough money is available for 5 runs, and there is a chance that there will be enough for 5 more. However, if the money for the additional 5 runs does not materialize, then the first 5 runs must be a Latin hypercube alone. A design for this situation can be created using the `lhs` package. First create a random Latin hypercube using the `randomLHS(n, k)` command: ```{r randomlhs} A <- randomLHS(5,2) ``` An example of this hypercube is shown in `r registerFigure("X")`. Note that the *Latin* property of the hypercube requires that each of the 5 equal probability intervals be filled (i.e. each row and each column is filled with one point). Also notice that the exact location of the design point is randomly sampled from within that cell using a uniform distribution for each marginal variable. ----- `r addFigureCaption("X", "A randomly produced Latin Hypercube with uniform marginal distributions for 2 parameters with 5 simulations", register=FALSE)` ```{r original5, echo=FALSE, fig.align='center', fig.height=5, fig.width=5} set.seed(10) X <- graph2DaugmentLHS1(5, 5) ``` ----- Next, in order to augment the design with more points use `augmentLHS(lhs, m)`. The following will add 5 more points to the design: ```{r augment5} B <- augmentLHS(A, 5) ``` The `augmentLHS` function works by re-dividing the original design into `n+m` intervals (e.g. 5+5=10) keeping the original design points exactly in the same position. It then randomly fills the empty row-column sets. The results are shown in `r registerFigure("Y")`. ----- `r addFigureCaption("Y", "A randomly produced Latin Hypercube of 5 points (red) with 5 augmented points (blue). Each parameter has a uniform marginal distribution.", register=FALSE)` ```{r augmented10, fig.align='center', echo=FALSE, fig.height=5, fig.width=5} graph2DaugmentLHS2(X) ``` ----- The `augmentLHS` function uses the following algorithm (see the documentation for `augmentLHS`): * Create a new `(n+m)` by `k` matrix to hold the candidate points after the design has been re-partitioned into `(n+m)^2` cells, where `n` is number of points in the original `lhs` matrix. * Then randomly sweep through each column (1...`k`) in the repartitioned design to find the missing cells. * For each column (variable), randomly search for an empty row, generate a random value that fits in that row, record the value in the new matrix. The new matrix can contain more than `m` points unless `m = 2n`, in which case the new matrix will contain exactly `m` filled rows. * Finally, keep only the first `m` rows of the new matrix. It is guaranteed that there will be `m` full rows (points) in the new matrix. The deleted rows are partially full. The additional candidate points are selected randomly because of the random search used to find empty cells. Also notice that because the original points are randomly placed within the cells, depending on how you bin the marginal distributions, a histogram (of x1 for example) will not necessarily be exactly uniform. Now, the augmenting points do not necessarily form a Latin Hypercube themselves. The original design and augmenting points may form a Latin Hypercube, or there may be more than one point per row in the augmented design. If the augmented points are equal to the number of original points, then a strictly uniform Latin hypercube is guaranteed. An example of an augmented design which is not uniform in the marginal distributions is given in `r registerFigure("Z")` and `r registerFigure("W")`. The commands were: ```{r random_and_augment} A <- randomLHS(7, 2) B <- augmentLHS(A, 3) ``` ----- `r addFigureCaption("Z", "Original design with 7 points", register=FALSE)` ```{r Z, echo=FALSE, fig.align='center', fig.height=5, fig.width=5} set.seed(12) X <- graph2DaugmentLHS1(7, 3) ``` ----- `r addFigureCaption("W", "Augmented design with 3 additional points. Note that row 9 has 2 points and row 3 has none.", register=FALSE)` ```{r W, echo=FALSE, fig.align='center', fig.height=5, fig.width=5} graph2DaugmentLHS2(X) ``` lhs/inst/doc/lhs_faq.html0000644000176200001440000035510713425401600015073 0ustar liggesusers Latin Hypercube Samples - Questions

Latin Hypercube Samples - Questions

Rob Carnell

2019-02-02

Question 1

I am looking for a package which gives me latin hyper cube samples from a grid of values:

a <- (1:10) 
b <- (20:30) 
dataGrid <- expand.grid(a, b)

Answer

The lhs package returns a uniformly distributed stratified sample from the unit hypercube. The marginal distributions can then be transformed to your distribution of choice. If you wanted a uniform Latin hypercube on [1,10] and [20,30] with 22 samples, you could do:

X <- randomLHS(22, 2) 
X[,1] <- 1 + 9*X[,1] 
X[,2] <- 20 + 10*X[,2] 

# OR 

Y <- randomLHS(22, 2) 
Y[,1] <- qunif(Y[,1], 1, 9) 
Y[,2] <- qunif(Y[,2], 20, 30) 

head(X)
#>          [,1]     [,2]
#> [1,] 6.403070 29.19494
#> [2,] 4.316480 27.03305
#> [3,] 4.189961 21.62021
#> [4,] 7.321731 20.15001
#> [5,] 9.229561 21.06021
#> [6,] 4.766257 27.51509
head(Y)
#>          [,1]     [,2]
#> [1,] 5.870586 24.56478
#> [2,] 3.465375 24.42880
#> [3,] 2.609169 27.42119
#> [4,] 4.674542 28.56320
#> [5,] 3.579832 25.25066
#> [6,] 8.582338 26.39973

If you want integers only in the sample, then we must be careful about what we mean by a Latin hypercube sample. If you wanted exactly 3 points, then you could divide up the range [1,10] into three almost equal parts and sample from 1:3, 4:6, and 7:10. The problem is that it wouldn’t be uniform sample across the range. (7 would be sampled less often than 2 for example)

To do a Latin hypercube sample on the intgers, you should have a number of integers on the margins which have the number of points sampled as a common factor. For example if you sample 3 points from 1:9, and 21:32 then you could sample as follows:

a <- c(sample(1:3,1), sample(4:6, 1), sample(7:9, 1)) 
b <- c(sample(21:24,1), sample(25:28, 1), sample(29:32,1))

and then randomly permute the entries of a and b.

Or more generally, take n samples from the list of integer groups:

integerLHS <- function(n, intGroups) 
{ 
  stopifnot(all(lapply(intGroups, function(X) length(X) %% n) == 0)) 
  stopifnot(require(lhs)) 
  stopifnot(is.list(intGroups)) 
  ranges <- lapply(intGroups, function(X) max(X) - min(X)) 
  A <- matrix(nrow = n, ncol = length(intGroups)) 
  for (j in 1:length(ranges)) 
  { 
    sequ <- order(runif(n)) 
    if (length(intGroups[[1]]) > 1) 
    { 
      spacing <- intGroups[[j]][2] - intGroups[[j]][1] 
    } else stop("must have more than 1 intGroup") 
    for (k in 1:n) 
    { 
      i <- sequ[k] 
      a <- min(intGroups[[j]]) + (i - 1)*(ranges[[j]] + spacing)/n 
      b <- min(intGroups[[j]]) + i*(ranges[[j]] + spacing)/n - 1 
      if (a < b) 
      { 
        A[k,j] <- sample(seq(a,b,spacing), 1) 
      } else if (a == b) 
      { 
        A[k,j] <- a 
      } else stop("error") 
    } 
  } 
  return(A) 
} 

integerLHS(10, list(1:10, 31:40)) 
#>       [,1] [,2]
#>  [1,]    5   36
#>  [2,]    2   31
#>  [3,]   10   39
#>  [4,]    4   32
#>  [5,]    7   38
#>  [6,]    9   40
#>  [7,]    1   37
#>  [8,]    3   33
#>  [9,]    8   35
#> [10,]    6   34
integerLHS(5, list(1:10, 31:40)) 
#>      [,1] [,2]
#> [1,]    1   35
#> [2,]    6   39
#> [3,]    8   33
#> [4,]    3   31
#> [5,]   10   38
integerLHS(2, list(1:10, 31:40)) 
#>      [,1] [,2]
#> [1,]    4   35
#> [2,]    6   38
integerLHS(5, list(1:20, 31:60, 101:115)) 
#>      [,1] [,2] [,3]
#> [1,]   20   57  104
#> [2,]   12   36  109
#> [3,]    8   44  114
#> [4,]   14   40  111
#> [5,]    4   50  101
integerLHS(5, list(seq(2,20,2), 31:60, 101:115)) 
#>      [,1] [,2] [,3]
#> [1,]    2   50  105
#> [2,]    6   34  110
#> [3,]   18   40  109
#> [4,]   10   46  103
#> [5,]   16   56  115

Question 2

I am trying to do a Latin Hypercube Sampling (LHS) to a 5-parameter design matrix. I want the combination of the first three parameters to sum up to 1 (which obviously do not)

If I divide each of these parameters with the sum, the uniform distribution is lost. Is there a way to maintain the random LHS (with uniformly distributed parameters) so that the refered condition is fulfilled?

Answer

In my experience with Latin hypercube samples, most people draw the sample on a uniform hypercube and then transform the uniform cube to have new distributions on the margins. The transformed distributions are not necessarily uniform. It is possible to draw a Latin hypercube with correlated margins and I hope to add that to my package in the future. I have also done transforms such that the transformed marginal distributions are correlated (as you have in your example). I have not seen a correlated set of uniform marginal distributions such that the margins sum to one, however. I’ll make a quick example argument that explains the difficulty…

In two dimensions, you could draw this which is uniform and correlated.

x <- seq(0.05, 0.95, length = 10) 
y <- 1 - x 
all.equal(x + y, rep(1, length(x))) 
#> [1] TRUE
hist(x, main = "") 

hist(y, main = "")

But in three dimensions, it is hard to maintain uniformity because large samples on the first uniform margin overweight the small samples on the other margins.

x <- seq(0.05, 0.95, length = 10) 
y <- runif(length(x), 0, 1 - x) 
z <- 1 - x - y 
hist(x, main = "") 

hist(y, main = "") 

hist(z, main = "")

The commmon practice in your situation is draw the K parameters together as a uniform Latin hypercube on 0-1 and then transform the margins of the hypercube to the desired distributions.

Easy Example * Parameter 1: normal(1, 2) * Parameter 2: normal(3, 4) * Parameter 3: uniform(5, 10)

N <- 1000 
x <- randomLHS(N, 3) 
y <- x 
y[,1] <- qnorm(x[,1], 1, 2) 
y[,2] <- qnorm(x[,2], 3, 4) 
y[,3] <- qunif(x[,3], 5, 10) 

par(mfrow = c(2,2)) 
dummy <- apply(x, 2, hist, main = "") 

par(mfrow = c(2,2)) 

dummy <- apply(y, 2, hist, main = "")

The transformed distributions maintain their “Latin” properties, but are in the form of new distributions.

In your case, you’d like the first three columns to be transformed into a correlated set that sums to one. Still follow the pattern…

x <- randomLHS(N, 5) 
y <- x 
y[,1] <- x[,1]/rowSums(x[,1:3]) 
y[,2] <- x[,2]/rowSums(x[,1:3]) 
y[,3] <- x[,3]/rowSums(x[,1:3]) 
y[,4] <- x[,4] 
y[,5] <- x[,5] 

par(mfrow = c(2,3)) 
dummy <- apply(x, 2, hist, main = "") 

par(mfrow = c(2,3)) 

dummy <- apply(y, 2, hist, main = "") 

all.equal(rowSums(y[,1:3]), rep(1, nrow(y))) 
#> [1] TRUE

The uniform properties are gone as you can see here…

par(mfrow = c(1,1)) 
pairs(x) 

pairs(y, col = "red")

But, the “Latin” properties of the first three margins are maintained as in this smaller example…

N <- 10 
x <- randomLHS(N, 5) 
y <- x 
y[,1] <- x[,1]/rowSums(x[,1:3]) 
y[,2] <- x[,2]/rowSums(x[,1:3]) 
y[,3] <- x[,3]/rowSums(x[,1:3]) 
y[,4] <- x[,4] 
y[,5] <- x[,5] 

pairs(x) 

pairs(y, col = "red")

Question 3

How do I create a Latin hypercube that ranges between between 0 and 1 and sums to 1?

Answer

I have an imperfect solution to this problem using a Dirichlet distribution.
The Dirichlet seems to keep the range of the values larger once they are normalized. The result is not uniformly distributed on (0,1) anymore, but instead is Dirichlet distributed with the parameters alpha. The Latin properties are maintained.

qdirichlet <- function(X, alpha) 
{ 
  # qdirichlet is not an exact quantile function since the quantile of a 
  #  multivariate distribtion is not unique 
  # qdirichlet is also not the quantiles of the marginal distributions since 
  #  those quantiles do not sum to one 
  # qdirichlet is the quantile of the underlying gamma functions, normalized 
  # This has been tested to show that qdirichlet approximates the dirichlet 
  #  distribution well and creates the correct marginal means and variances 
  #  when using a latin hypercube sample 
  lena <- length(alpha) 
  stopifnot(is.matrix(X)) 
  sims <- dim(X)[1] 
  stopifnot(dim(X)[2] == lena) 
  if (any(is.na(alpha)) || any(is.na(X))) 
    stop("NA values not allowed in qdirichlet") 

  Y <- matrix(0, nrow = sims, ncol = lena) 
  ind <- which(alpha != 0) 
  for (i in ind) 
  { 
    Y[,i] <- qgamma(X[,i], alpha[i], 1) 
  } 
  Y <- Y / rowSums(Y) 
  return(Y) 
} 

X <- randomLHS(1000, 7) 
Y <- qdirichlet(X, rep(1,7)) 
stopifnot(all(abs(rowSums(Y) - 1) < 1E-12)) 
range(Y) 
#> [1] 1.926871e-05 7.941305e-01

ws <- randomLHS(1000, 7) 
wsSums <- rowSums(ws) 
wss <- ws / wsSums 
stopifnot(all(abs(rowSums(wss) - 1) < 1E-12)) 
range(wss)
#> [1] 1.148462e-05 4.451393e-01

Question 5

I need to use Latin hypercube sampling for my own custome functions.

Answer

require(lhs) 

# functions you described 
T1 <- function(t) t*t 
WL1 <- function(T1, t) T1*t 
BE1 <- function(WL1, T1, t) WL1*T1*t 

# t is distributed according to some pdf (e.g. normal) 
# draw a lhs with 512 rows and 3 columns (one for each function) 
y <- randomLHS(512, 3) 
# transform the three columns to a normal distribution (these could be any 
# distribution) 
t <- apply(y, 2, function(columny) qnorm(columny, 2, 1)) 
# transform t using the functions provided 
result <- cbind( 
  T1(t[,1]), 
  WL1(T1(t[,2]), t[,2]), 
  BE1(WL1(T1(t[,3]), t[,3]), T1(t[,3]), t[,3]) 
) 
# check the results 
# these should be approximately uniform 
par(mfrow = c(2,2)) 
dummy <- apply(y, 2, hist, breaks = 50, main = "") 
# these should be approximately normal 
par(mfrow = c(2,2)) 

dummy <- apply(t, 2, hist, breaks = 50, main = "") 
# these should be the results of the functions 
par(mfrow = c(2,2)) 

dummy <- apply(result, 2, hist, breaks = 50, main = "")

Question 6

I need a Latin hypercube sample on an integer set or a set of colors.

Answer

N <- 1000 
set.seed(1919) 

x <- randomLHS(N, 4) 
y <- x 
# uniform on 1-10 
y[,1] <- ceiling(qunif(x[,1], 0, 10)) 
# three colors 1,2,3 
y[,2] <- ceiling(qunif(x[,2], 0, 3)) 
# other distributions 
y[,3] <- qunif(x[,3], 5, 10) 
y[,4] <- qnorm(x[,4], 0, 2) 

par(mfrow=c(2,2)) 
dummy <- apply(x, 2, hist, main="") 


par(mfrow=c(2,2)) 
plot(1:10, c(table(y[,1])), type="h", col="blue", lwd=2, ylim=c(0,120), 
ylab="Frequency", xlab="y[,1]") 
plot(1:3, c(table(y[,2])), type="h", col="blue", lwd=2, ylim=c(0,400), 
ylab="Frequency", xlab="y[,2]") 
hist(y[,3], main="") 
hist(y[,4], main="") 


# change to color names 
z <- as.data.frame(y) 
z[,2] <- factor(y[,2], labels=c("R","G","B")) 
z[1:10,] 
#>    V1 V2       V3          V4
#> 1   9  R 9.944182  2.94805877
#> 2   4  R 8.530678 -0.19388895
#> 3   8  G 8.095066 -0.89251244
#> 4   4  G 8.198067 -0.45032286
#> 5  10  G 6.523280 -4.09957931
#> 6  10  B 6.227534 -0.05631367
#> 7   2  B 7.177990  3.84640466
#> 8   8  G 6.881714  0.58980996
#> 9   9  G 7.111466  0.45285007
#> 10  2  R 6.172652  1.93023633
lhs/inst/doc/lhs_basics.html0000644000176200001440000027562113425401576015606 0ustar liggesusers Basic Latin hypercube samples and designs with package lhs

Basic Latin hypercube samples and designs with package lhs

Rob Carnell

2019-02-02

Theory of Latin Hypercube Sampling

For the technical basis of Latin Hypercube Sampling (LHS) and Latin Hypercube Designs (LHD) please see: * Stein, Michael. Large Sample Properties of Simulations Using Latin Hypercube Sampling Technometrics, Vol 28, No 2, 1987. * McKay, MD, et.al. A Comparison of Three Methods for Selecting Values of Input Variables in the Analysis of Output from a Computer Code Technometrics, Vol 21, No 2, 1979.

This package was created to bring these designs to R and to implement many of the articles that followed on optimized sampling methods.

Create a Simple LHS

Basic LHS’s are created using randomLHS.

# set the seed for reproducibility
set.seed(1111)
# a design with 5 samples from 4 parameters
A <- randomLHS(5, 4) 
A
#>           [,1]       [,2]      [,3]      [,4]
#> [1,] 0.6328827 0.48424369 0.1678234 0.1974741
#> [2,] 0.2124960 0.88111537 0.6069217 0.4771109
#> [3,] 0.1277885 0.64327868 0.3612360 0.9862456
#> [4,] 0.8935830 0.27182878 0.4335808 0.6052341
#> [5,] 0.5089423 0.02269382 0.8796676 0.2036678

In general, the LHS is uniform on the margins until transformed (Figure 1):

Figure 1. Two dimensions of a Uniform random LHS with 5 samples

It is common to transform the margins of the design (the columns) into other distributions (Figure 2)

B <- matrix(nrow = nrow(A), ncol = ncol(A))
B[,1] <- qnorm(A[,1], mean = 0, sd = 1)
B[,2] <- qlnorm(A[,2], meanlog = 0.5, sdlog = 1)
B[,3] <- A[,3]
B[,4] <- qunif(A[,4], min = 7, max = 10)
B
#>             [,1]      [,2]      [,3]     [,4]
#> [1,]  0.33949794 1.5848575 0.1678234 7.592422
#> [2,] -0.79779049 5.3686737 0.6069217 8.431333
#> [3,] -1.13690757 2.3803237 0.3612360 9.958737
#> [4,]  1.24581019 0.8982639 0.4335808 8.815702
#> [5,]  0.02241694 0.2228973 0.8796676 7.611003
Figure 2. Two dimensions of a transformed random LHS with 5 samples

Optimizing the Design

The LHS can be optimized using a number of methods in the lhs package. Each method attempts to improve on the random design by ensuring that the selected points are as uncorrelated and space filling as possible. Table 1 shows some results. Figure 3, Figure 4, and Figure 5 show corresponding plots.

set.seed(101)
A <- randomLHS(30, 10)
A1 <- optimumLHS(30, 10, maxSweeps = 4, eps = 0.01)
A2 <- maximinLHS(30, 10, dup = 5)
A3 <- improvedLHS(30, 10, dup = 5)
A4 <- geneticLHS(30, 10, pop = 1000, gen = 8, pMut = 0.1, criterium = "S")
A5 <- geneticLHS(30, 10, pop = 1000, gen = 8, pMut = 0.1, criterium = "Maximin")
Table 1. Sample results and metrics of various LHS algorithms
Method Min Distance btwn pts Mean Distance btwn pts Max Correlation btwn pts
randomLHS 0.6346585 1.2913235 0.5173006
optimumLHS 0.8717797 1.3001892 0.1268209
maximinLHS 0.595395 1.2835191 0.2983643
improvedLHS 0.6425673 1.2746711 0.5711527
geneticLHS (S) 0.8340751 1.3026543 0.3971539
geneticLHS (Maximin) 0.8105733 1.2933412 0.5605546
Figure 3. Pairwise margins of a randomLHS

Figure 4. Pairwise margins of a optimumLHS

Figure 5. Pairwise margins of a maximinLHS

lhs/inst/doc/augment_lhs.R0000644000176200001440000000427413425401565015227 0ustar liggesusers## ----setup, include = FALSE---------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) source("VignetteCommonCode.R") require(lhs) graph2DaugmentLHS1 <- function(sims, extras) { A <- randomLHS(sims, 2) B <- augmentLHS(A, extras) plot.default(A[,1], A[,2], type = "n", ylim = c(0,1), xlim = c(0,1), xlab = "x1", ylab = "x2", xaxs = "i", yaxs = "i", main = "") for (i in 1:length(A[,1])) { rect(floor(A[i,1]*sims)/sims, floor(A[i,2]*sims)/sims, ceiling(A[i,1]*sims)/sims, ceiling(A[i,2]*sims)/sims, col = "grey") } points(A[,1], A[,2], pch = 19, col = "red") abline(v = (0:sims)/sims, h = (0:sims)/sims) return(list(A = A, B = B, sims = sims, extras = extras)) } graph2DaugmentLHS2 <- function(X) { A <- X$A B <- X$B sims <- X$sims extras <- X$extras plot.default(A[,1], A[,2], type = "n", ylim = c(0,1), xlim = c(0,1), xlab = "x1", ylab = "x2", xaxs = "i", yaxs = "i", main = "") N <- sims + extras for (i in 1:length(B[,1])) { rect(floor(B[i,1]*N)/N, floor(B[i,2]*N)/N, ceiling(B[i,1]*N)/N, ceiling(B[i,2]*N)/N, col = "grey") } points(A[,1], A[,2], pch = 19, col = "red") points(B[((sims + 1):(sims + extras)), 1], B[((sims + 1):(sims + extras)), 2], pch = 19, col = "blue") abline(v = (0:N)/N, h = (0:N)/N) } # X <- graph2DaugmentLHS1(5,5) # graph2DaugmentLHS2(X) ## ----randomlhs----------------------------------------------------------- A <- randomLHS(5,2) ## ----original5, echo=FALSE, fig.align='center', fig.height=5, fig.width=5---- set.seed(10) X <- graph2DaugmentLHS1(5, 5) ## ----augment5------------------------------------------------------------ B <- augmentLHS(A, 5) ## ----augmented10, fig.align='center', echo=FALSE, fig.height=5, fig.width=5---- graph2DaugmentLHS2(X) ## ----random_and_augment-------------------------------------------------- A <- randomLHS(7, 2) B <- augmentLHS(A, 3) ## ----Z, echo=FALSE, fig.align='center', fig.height=5, fig.width=5-------- set.seed(12) X <- graph2DaugmentLHS1(7, 3) ## ----W, echo=FALSE, fig.align='center', fig.height=5, fig.width=5-------- graph2DaugmentLHS2(X) lhs/inst/doc/lhs_basics.Rmd0000644000176200001440000001717213416533265015360 0ustar liggesusers--- title: "Basic Latin hypercube samples and designs with package lhs" author: "Rob Carnell" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Basic Latin hypercube samples and designs with package lhs} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} %\VignetteAuthor{Rob Carnell} %\VignetteKeyword{lhs} %\VignetteKeyword{latin hypercube} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) require(lhs) source("VignetteCommonCode.R") graph2dLHS <- function(Alhs) { stopifnot(ncol(Alhs) == 2) sims <- nrow(Alhs) par(mar = c(4,4,2,2)) plot.default(Alhs[,1], Alhs[,2], type = "n", ylim = c(0,1), xlim = c(0,1), xlab = "Parameter 1", ylab = "Parameter 2", xaxs = "i", yaxs = "i", main = "") for (i in 1:nrow(Alhs)) { rect(floor(Alhs[i,1]*sims)/sims, floor(Alhs[i,2]*sims)/sims, ceiling(Alhs[i,1]*sims)/sims, ceiling(Alhs[i,2]*sims)/sims, col = "grey") } points(Alhs[,1], Alhs[,2], pch = 19, col = "red") abline(v = (0:sims)/sims, h = (0:sims)/sims) } # transform is a function of the kind that takes a number # transform <- function(x){return(qnorm(x,mean=0, std=1))} graph2dLHSTransform <- function(Alhs, transform1, transform2, min1, max1, min2, max2) { stopifnot(ncol(Alhs) == 2) stopifnot(all(Alhs[,1] <= max1 && Alhs[,1] >= min1)) stopifnot(all(Alhs[,2] <= max2 && Alhs[,2] >= min2)) sims <- nrow(Alhs) breaks <- seq(0,1,length = sims + 1)[2:(sims)] breaksTransformed1 <- sapply(breaks, transform1) breaksTransformed2 <- sapply(breaks, transform2) par(mar = c(4,4,2,2)) plot.default(Alhs[,1], Alhs[,2], type = "n", ylim = c(min2, max2), xlim = c(min1, max1), xlab = "Parameter 1", ylab = "Parameter 2", xaxs = "i", yaxs = "i", main = "") for (si in 1:sims) { temp <- Alhs[si,] for (i in 1:sims) { if ((i == 1 && min1 <= temp[1] && breaksTransformed1[i] >= temp[1]) || (i == sims && max1 >= temp[1] && breaksTransformed1[i - 1] <= temp[1]) || (breaksTransformed1[i - 1] <= temp[1] && breaksTransformed1[i] >= temp[1])) { for (j in 1:sims) { if ((j == 1 && min2 <= temp[2] && breaksTransformed2[j] >= temp[2]) || (j == sims && max2 >= temp[2] && breaksTransformed2[j - 1] <= temp[2]) || (breaksTransformed2[j - 1] <= temp[2] && breaksTransformed2[j] >= temp[2])) { if (i == 1) { xbot <- min1 xtop <- breaksTransformed1[i] } else if (i == sims) { xbot <- breaksTransformed1[i - 1] xtop <- max1 } else { xbot <- breaksTransformed1[i - 1] xtop <- breaksTransformed1[i] } if (j == 1) { ybot <- min2 ytop <- breaksTransformed2[j] } else if (j == sims) { ybot <- breaksTransformed2[j - 1] ytop <- max2 } else { ybot <- breaksTransformed2[j - 1] ytop <- breaksTransformed2[j] } rect(xbot, ybot, xtop, ytop, col = "grey") } } } } } points(Alhs[,1], Alhs[,2], pch = 19, col = "red") abline(v = breaksTransformed1, h = breaksTransformed2) } #set.seed(1111) #A <- randomLHS(5,4) #f <- function(x){qnorm(x)} #g <- function(x){qlnorm(x, meanlog=0.5, sdlog=1)} #B <- A #B[,1] <- f(A[,1]) #B[,2] <- g(A[,2]) #graph2dLHSTransform(B[,1:2], f, g, -4, 4, 0, 8) #f <- function(x){qunif(x, 3, 5)} #B <- apply(A, 2, f) #graph2dLHSTransform(B[,1:2], f) ``` ### Theory of Latin Hypercube Sampling For the technical basis of Latin Hypercube Sampling (LHS) and Latin Hypercube Designs (LHD) please see: * Stein, Michael. _Large Sample Properties of Simulations Using Latin Hypercube Sampling_ Technometrics, Vol 28, No 2, 1987. * McKay, MD, et.al. _A Comparison of Three Methods for Selecting Values of Input Variables in the Analysis of Output from a Computer Code_ Technometrics, Vol 21, No 2, 1979. This package was created to bring these designs to R and to implement many of the articles that followed on optimized sampling methods. ### Create a Simple LHS Basic LHS's are created using `randomLHS`. ```{r block1} # set the seed for reproducibility set.seed(1111) # a design with 5 samples from 4 parameters A <- randomLHS(5, 4) A ``` In general, the LHS is uniform on the margins until transformed (`r registerFigure("X")`): `r addFigureCaption("X", "Two dimensions of a Uniform random LHS with 5 samples", register=FALSE)` ```{r figureX, fig.align='center', fig.height=5, fig.width=5, echo=FALSE} graph2dLHS(A[,1:2]) ``` It is common to transform the margins of the design (the columns) into other distributions (`r registerFigure("Y")`) ```{r block 3} B <- matrix(nrow = nrow(A), ncol = ncol(A)) B[,1] <- qnorm(A[,1], mean = 0, sd = 1) B[,2] <- qlnorm(A[,2], meanlog = 0.5, sdlog = 1) B[,3] <- A[,3] B[,4] <- qunif(A[,4], min = 7, max = 10) B ``` `r addFigureCaption("Y", "Two dimensions of a transformed random LHS with 5 samples", register=FALSE)` ```{r figureY, fig.align='center', fig.height=5, fig.width=5, echo=FALSE} f <- function(x){qnorm(x)} g <- function(x){qlnorm(x, meanlog = 0.5, sdlog = 1)} graph2dLHSTransform(B[,1:2], f, g, -4, 4, 0, 8) ``` ### Optimizing the Design The LHS can be optimized using a number of methods in the `lhs` package. Each method attempts to improve on the random design by ensuring that the selected points are as uncorrelated and space filling as possible. `r registerTable("tab1")` shows some results. `r registerFigure("Z")`, `r registerFigure("W")`, and `r registerFigure("G")` show corresponding plots. ```{r block 4} set.seed(101) A <- randomLHS(30, 10) A1 <- optimumLHS(30, 10, maxSweeps = 4, eps = 0.01) A2 <- maximinLHS(30, 10, dup = 5) A3 <- improvedLHS(30, 10, dup = 5) A4 <- geneticLHS(30, 10, pop = 1000, gen = 8, pMut = 0.1, criterium = "S") A5 <- geneticLHS(30, 10, pop = 1000, gen = 8, pMut = 0.1, criterium = "Maximin") ``` ----- `r addTableCaption("tab1", "Sample results and metrics of various LHS algorithms", register=FALSE)` Method | Min Distance btwn pts | Mean Distance btwn pts | Max Correlation btwn pts :-----|:-----:|:-----:|:-----: randomLHS | `r min(dist(A))` | `r mean(dist(A))` | `r max(abs(cor(A)-diag(10)))` optimumLHS | `r min(dist(A1))` | `r mean(dist(A1))` | `r max(abs(cor(A1)-diag(10)))` maximinLHS | `r min(dist(A2))` | `r mean(dist(A2))` | `r max(abs(cor(A2)-diag(10)))` improvedLHS | `r min(dist(A3))` | `r mean(dist(A3))` | `r max(abs(cor(A3)-diag(10)))` geneticLHS (S) | `r min(dist(A4))` | `r mean(dist(A4))` | `r max(abs(cor(A4)-diag(10)))` geneticLHS (Maximin) | `r min(dist(A5))` | `r mean(dist(A5))` | `r max(abs(cor(A5)-diag(10)))` ----- `r addFigureCaption("Z", "Pairwise margins of a randomLHS", register=FALSE)` ```{r Z, fig.align='center', fig.height=7, fig.width=7, echo=FALSE} pairs(A, pch = 19, col = "blue", cex = 0.5) ``` ----- `r addFigureCaption("W", "Pairwise margins of a optimumLHS", register=FALSE)` ```{r W, fig.align='center', fig.height=7, fig.width=7, echo=FALSE} pairs(A1, pch = 19, col = "blue", cex = 0.5) ``` ----- `r addFigureCaption("G", "Pairwise margins of a maximinLHS", register=FALSE)` ```{r G, fig.align='center', fig.height=7, fig.width=7, echo=FALSE} pairs(A2, pch = 19, col = "blue", cex = 0.5) ``` lhs/inst/doc/augment_lhs.html0000644000176200001440000010367413425401565015776 0ustar liggesusers An Example of Augmenting a Latin Hypercube

An Example of Augmenting a Latin Hypercube

Rob Carnell

2019-02-02

Suppose that a computer simulation study is being designed that requires expensive runs. A Latin hypercube design is desired for this simulation so that the expectation of the simulation output can be estimated efficiently given the distributions of the input variables. Latin hypercubes are most often used in highly dimensional problems, but the example shown is of small dimension. Suppose further that the total extent of funding is uncertain. Enough money is available for 5 runs, and there is a chance that there will be enough for 5 more. However, if the money for the additional 5 runs does not materialize, then the first 5 runs must be a Latin hypercube alone. A design for this situation can be created using the lhs package.

First create a random Latin hypercube using the randomLHS(n, k) command:

A <- randomLHS(5,2)

An example of this hypercube is shown in Figure 1. Note that the Latin property of the hypercube requires that each of the 5 equal probability intervals be filled (i.e. each row and each column is filled with one point). Also notice that the exact location of the design point is randomly sampled from within that cell using a uniform distribution for each marginal variable.

Figure 1. A randomly produced Latin Hypercube with uniform marginal distributions for 2 parameters with 5 simulations

Next, in order to augment the design with more points use augmentLHS(lhs, m). The following will add 5 more points to the design:

B <- augmentLHS(A, 5)

The augmentLHS function works by re-dividing the original design into n+m intervals (e.g. 5+5=10) keeping the original design points exactly in the same position. It then randomly fills the empty row-column sets. The results are shown in Figure 2.

Figure 2. A randomly produced Latin Hypercube of 5 points (red) with 5 augmented points (blue). Each parameter has a uniform marginal distribution.

The augmentLHS function uses the following algorithm (see the documentation for augmentLHS):

Also notice that because the original points are randomly placed within the cells, depending on how you bin the marginal distributions, a histogram (of x1 for example) will not necessarily be exactly uniform.

Now, the augmenting points do not necessarily form a Latin Hypercube themselves. The original design and augmenting points may form a Latin Hypercube, or there may be more than one point per row in the augmented design. If the augmented points are equal to the number of original points, then a strictly uniform Latin hypercube is guaranteed. An example of an augmented design which is not uniform in the marginal distributions is given in Figure 3 and Figure 4. The commands were:

A <- randomLHS(7, 2)
B <- augmentLHS(A, 3)
Figure 3. Original design with 7 points

Figure 4. Augmented design with 3 additional points. Note that row 9 has 2 points and row 3 has none.

lhs/tests/0000755000176200001440000000000013415250176012206 5ustar liggesuserslhs/tests/testthat.R0000644000176200001440000000006613415250176014173 0ustar liggesuserslibrary(testthat) library(lhs) test_check("lhs") lhs/tests/testthat/0000755000176200001440000000000013425544676014062 5ustar liggesuserslhs/tests/testthat/helper-lhs.R0000644000176200001440000000125413422722473016240 0ustar liggesusers# Copyright 2019 Robert Carnell checkLatinHypercube <- function(X) { if (any(apply(X, 2, min) <= 0)) return(FALSE) if (any(apply(X, 2, max) >= 1)) return(FALSE) if (any(is.na(X))) return(FALSE) # check that the matrix is a latin hypercube g <- function(Y) { # check that this column contains all the cells breakpoints <- seq(0, 1, length = length(Y) + 1) h <- hist(Y, plot = FALSE, breaks = breakpoints) all(h$counts == 1) } # check all the columns return(all(apply(X, 2, g))) } checkOA <- function(X) { # check that the matrix is an orthogonal array Y <- t(X) %*% X all(abs(Y[upper.tri(Y)]) < 1E-9) } lhs/tests/testthat/test-createoa.R0000644000176200001440000001246613420473711016740 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-createoa") test_that("createBose works", { B <- createBose(2, 3, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 expect_true(checkOA(B)) B <- createBose(3, 4, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- 0 B[which(B == 2, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) B <- createBose(3, 3) expect_equal(nrow(B), 3^2) expect_equal(ncol(B), 3) B <- createBose(3, 4) expect_equal(nrow(B), 3^2) expect_equal(ncol(B), 4) B <- createBose(5, 4) expect_equal(nrow(B), 5^2) expect_equal(ncol(B), 4) expect_error(.Call("oa_type1", "bose", 3, 3L, FALSE)) expect_error(.Call("oa_type1", 0, 3L, 3L, FALSE)) expect_error(.Call("oa_type1", "bose", c(3L, 4L), 3L, FALSE)) expect_error(.Call("oa_type1", "bose", as.integer(NA), 3L, FALSE)) expect_error(.Call("oa_type1", "bob", 3L, 3L, FALSE)) }) test_that("createBoseBush works", { B <- createBoseBush(2, 4, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 expect_true(checkOA(B)) B <- createBoseBush(4, 8, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- -1/3 B[which(B == 2, arr.ind = TRUE)] <- 1/3 B[which(B == 3, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) B <- createBoseBush(4, 5) expect_equal(nrow(B), 2*4^2) expect_equal(ncol(B), 5) B <- createBoseBush(4, 4) expect_equal(nrow(B), 2*4^2) expect_equal(ncol(B), 4) B <- createBoseBush(8, 3) expect_equal(nrow(B), 2*8^2) expect_equal(ncol(B), 3) }) test_that("createBush works", { B <- createBush(3, 3, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- 0 B[which(B == 2, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) B <- createBush(4, 5, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- -1/3 B[which(B == 2, arr.ind = TRUE)] <- 1/3 B[which(B == 3, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) B <- createBush(3, 3) expect_equal(nrow(B), 3^3) expect_equal(ncol(B), 3) B <- createBush(3, 4) expect_equal(nrow(B), 3^3) expect_equal(ncol(B), 4) B <- createBush(5, 4) expect_equal(nrow(B), 5^3) expect_equal(ncol(B), 4) }) test_that("createAddelKemp works", { B <- createAddelKemp(2, 4, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 expect_true(checkOA(B)) B <- createAddelKemp(3, 6, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- 0 B[which(B == 2, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) B <- createAddelKemp(4, 5) expect_equal(nrow(B), 2*4^2) expect_equal(ncol(B), 5) B <- createAddelKemp(4, 4) expect_equal(nrow(B), 2*4^2) expect_equal(ncol(B), 4) B <- createAddelKemp(5, 3) expect_equal(nrow(B), 2*5^2) expect_equal(ncol(B), 3) }) test_that("createAddelKemp3 works", { B <- createAddelKemp3(2, 13, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 expect_true(checkOA(B)) B <- createAddelKemp3(3, 25, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- 0 B[which(B == 2, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) B <- createAddelKemp3(4, 5) expect_equal(nrow(B), 2*4^3) expect_equal(ncol(B), 5) B <- createAddelKemp3(4, 4) expect_equal(nrow(B), 2*4^3) expect_equal(ncol(B), 4) B <- createAddelKemp3(5, 3) expect_equal(nrow(B), 2*5^3) expect_equal(ncol(B), 3) }) test_that("createBusht works", { B <- createBusht(3, 4, 2, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- 0 B[which(B == 2, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) B <- createBusht(3, 4, 3, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- 0 B[which(B == 2, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) expect_error(.Call("oa_type2", "busht", 3, 4L, 3L, FALSE)) expect_error(.Call("oa_type2", 0, 3L, 4L, 3L, FALSE)) expect_error(.Call("oa_type2", "busht", c(3L, 4L), 4L, 3L, FALSE)) expect_error(.Call("oa_type2", "busht", as.integer(NA), 4L, 3L, FALSE)) expect_error(.Call("oa_type2", "bosebushl", as.integer(NA), 4L, 3L, FALSE)) expect_error(.Call("oa_type2", "addelkempn", as.integer(NA), 4L, 3L, FALSE)) expect_error(.Call("oa_type2", "bob", as.integer(NA), 4L, 3L, FALSE)) expect_error(.Call("oa_type2", "bob", 3L, 4L, 3L, FALSE)) X <- .Call("oa_type2", "busht", 3L, 4L, 3L, TRUE) expect_equal(nrow(X), 64) }) test_that("createBoseBushl works", { B <- createBoseBushl(3, 5, 3, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- 0 B[which(B == 2, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) B <- createBoseBushl(4, 4, 16, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- -1/3 B[which(B == 2, arr.ind = TRUE)] <- 1/3 B[which(B == 3, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) }) test_that("createAddelKempN works", { B <- createAddelKempN(2, 3, 3, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 expect_true(checkOA(B)) B <- createAddelKempN(3, 4, 4, FALSE) B[which(B == 0, arr.ind = TRUE)] <- -1 B[which(B == 1, arr.ind = TRUE)] <- 0 B[which(B == 2, arr.ind = TRUE)] <- 1 expect_true(checkOA(B)) }) lhs/tests/testthat/test-improvedlhs.r0000644000176200001440000000227713423215476017555 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-improvedlhs") test_that("improvedLHS works", { expect_error(improvedLHS(-1, 2)) expect_error(improvedLHS(10, -30)) expect_error(improvedLHS(10, 2, -2)) expect_error(improvedLHS(NA, 2)) expect_error(improvedLHS(NaN, 2)) expect_warning(expect_error(improvedLHS(Inf, 2))) expect_error(improvedLHS(10, NA, 2)) expect_error(improvedLHS(10, NaN, 2)) expect_warning(expect_error(improvedLHS(10, Inf, 2))) expect_error(improvedLHS(10, 2, NA)) expect_error(improvedLHS(10, 2, NaN)) expect_warning(expect_error(improvedLHS(10, 2, Inf))) set.seed(1976) expect_true(checkLatinHypercube(improvedLHS(4, 2))) set.seed(1977) expect_true(checkLatinHypercube(improvedLHS(3, 3, 5))) set.seed(1111) A <- improvedLHS(20, 6) set.seed(1111) B <- improvedLHS(20, 6) expect_true(all(A == B)) D <- improvedLHS(20, 6) expect_true(any(A != D)) A <- improvedLHS(1, 4) expect_equal(nrow(A), 1) expect_true(checkLatinHypercube(A)) }) test_that("improvedLHS errors work", { expect_error(.Call("improvedLHS_cpp", 3, 4L, 4L)) X <- .Call("improvedLHS_cpp", 1L, 4L, 4L) expect_equal(nrow(X), 1) }) lhs/tests/testthat/test-randomlhs.r0000644000176200001440000000434213422725136017201 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-randomlhs") test_that("randomLHS works", { A <- randomLHS(4,2) expect_true(all(A > 0 & A < 1)) expect_equal(4, nrow(A)) expect_equal(2, ncol(A)) expect_true(checkLatinHypercube(A)) # doubles are truncated in n and k A <- randomLHS(4.4, 2) expect_true(all(A > 0 & A < 1)) expect_equal(4, nrow(A)) expect_equal(2, ncol(A)) expect_true(checkLatinHypercube(A)) A <- randomLHS(4, 2.8) expect_true(all(A > 0 & A < 1)) expect_equal(4, nrow(A)) expect_equal(2, ncol(A)) expect_true(checkLatinHypercube(A)) A <- randomLHS(4.4, 2.8) expect_true(all(A > 0 & A < 1)) expect_equal(4, nrow(A)) expect_equal(2, ncol(A)) expect_true(checkLatinHypercube(A)) expect_error(randomLHS(-1, 2)) expect_error(randomLHS(10, -30)) expect_error(randomLHS(NA, 2)) expect_error(randomLHS(NaN, 2)) expect_warning(expect_error(randomLHS(Inf, 2))) expect_error(randomLHS(10, NA)) expect_error(randomLHS(10, NaN)) expect_warning(expect_error(randomLHS(10, Inf))) A <- randomLHS(1, 5) expect_equal(1, nrow(A)) expect_equal(5, ncol(A)) expect_true(checkLatinHypercube(A)) expect_error(randomLHS(c(1,2,3), c(3,4))) expect_error(randomLHS(-1, 2, preserveDraw = TRUE)) expect_error(randomLHS(10, -30, preserveDraw = TRUE)) expect_error(randomLHS(NA, 2, preserveDraw = TRUE)) expect_error(randomLHS(NaN, 2, preserveDraw = TRUE)) expect_warning(expect_error(randomLHS(Inf, 2, preserveDraw = TRUE))) expect_error(randomLHS(10, NA, preserveDraw = TRUE)) expect_error(randomLHS(10, NaN, preserveDraw = TRUE)) expect_warning(expect_error(randomLHS(10, Inf, preserveDraw = TRUE))) A <- randomLHS(4, 2, preserveDraw = TRUE) expect_true(all(A > 0 & A < 1)) expect_true(checkLatinHypercube(A)) set.seed(4) A <- randomLHS(5, 3, preserveDraw = TRUE) set.seed(4) B <- randomLHS(5, 5, preserveDraw = TRUE) expect_equal(A, B[,1:3], tolerance = 1E-12) expect_true(checkLatinHypercube(A)) expect_true(checkLatinHypercube(B)) expect_error(.Call("randomLHS_cpp", 3, 4L, FALSE)) }) test_that("degenerate LHS problem is fixed", { A <- randomLHS(1, 3) expect_true(checkLatinHypercube(A)) }) lhs/tests/testthat/test-optimumlhs.R0000644000176200001440000000355213423217051017346 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-optimumlhs") test_that("optimumLHS works", { expect_error(optimumLHS(-1, 2)) expect_error(optimumLHS(10, -30)) expect_error(optimumLHS(10, 2, -2)) expect_error(optimumLHS(10, 2, 3, -1)) expect_error(optimumLHS(10, 2, 3, 1.5)) expect_error(optimumLHS(10, 2, 3, 1)) expect_error(optimumLHS(10, 2, 3, 0)) expect_error(optimumLHS(NA, 2)) expect_error(optimumLHS(NaN, 2)) expect_warning(expect_error(optimumLHS(Inf, 2))) expect_error(optimumLHS(10, NA)) expect_error(optimumLHS(10, NaN)) expect_warning(expect_error(optimumLHS(10, Inf))) expect_error(optimumLHS(10, 2, NA)) expect_error(optimumLHS(10, 2, NaN)) expect_warning(expect_error(optimumLHS(10, 2, Inf))) expect_error(optimumLHS(10, 2, 2, NA)) expect_error(optimumLHS(10, 2, 2, NaN)) expect_error(optimumLHS(10, 2, 2, Inf)) set.seed(1976) rTemp <- optimumLHS(4, 2) expect_true(checkLatinHypercube(rTemp)) set.seed(1977) rTemp <- optimumLHS(3, 3, 5) expect_true(checkLatinHypercube(rTemp)) set.seed(1978) rTemp <- optimumLHS(5, 2, 5, .5) expect_true(checkLatinHypercube(rTemp)) set.seed(2010) for (i in 2:6) { for (j in 2:6) { A <- optimumLHS(i, j) expect_true(checkLatinHypercube(A)) } } set.seed(2011) for (i in 2:6) { for (j in 2:6) { A <- optimumLHS(i, j, 5) expect_true(checkLatinHypercube(A)) } } set.seed(2012) for (i in 2:6) { for (j in 2:6) { A <- optimumLHS(i, j, 5, 0.05) expect_true(checkLatinHypercube(A)) } } expect_error(.Call("optimumLHS_cpp", 3, 4L, 4L, 0.01, FALSE)) X <- .Call("optimumLHS_cpp", 1L, 4L, 4L, 0.01, FALSE) expect_equal(nrow(X), 1) A <- optimumLHS(1, 4) expect_equal(nrow(A), 1) expect_true(checkLatinHypercube(A)) }) lhs/tests/testthat/test-geneticlhs.R0000644000176200001440000000301313423214736017271 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-geneticlhs") test_that("geneticLHS works", { expect_error(geneticLHS(-1, 2)) expect_error(geneticLHS(10, -30)) expect_error(geneticLHS(10, 2, -2)) expect_error(geneticLHS(NA, 2)) expect_error(geneticLHS(NaN, 2)) expect_warning(expect_error(geneticLHS(Inf, 2))) expect_error(geneticLHS(10, NA)) expect_error(geneticLHS(10, NaN)) expect_warning(expect_error(geneticLHS(10, Inf))) expect_error(geneticLHS(10, 2, NA)) expect_error(geneticLHS(10, 2, NaN)) expect_warning(expect_error(geneticLHS(10, 2, Inf))) set.seed(1976) expect_true(checkLatinHypercube(geneticLHS(4, 2))) set.seed(1977) expect_true(checkLatinHypercube(geneticLHS(3, 3, 6))) expect_error(geneticLHS(10, 2, 4, -1)) expect_error(geneticLHS(10, 2, 4, 4, -.1)) expect_error(geneticLHS(10, 2, 4, 4, 1.1)) expect_error(geneticLHS(10, 2, 2, NA)) expect_error(geneticLHS(10, 2, 2, NaN)) expect_warning(expect_error(geneticLHS(10, 2, 2, Inf))) #expect_error(geneticLHS(10, 2, 2, 4, NA)) #expect_error(geneticLHS(10, 2, 2, 4, NaN)) expect_error(geneticLHS(10, 2, 2, 4, Inf)) set.seed(1976) expect_true(checkLatinHypercube(geneticLHS(20, 5, pop = 100, gen = 4, pMut = 0.2, criterium = "S"))) capture_output(X <- .Call("geneticLHS_cpp", 1L, 4L, 10L, 4L, 0.01, "S", TRUE)) expect_equal(nrow(X), 1) A <- geneticLHS(1, 4) expect_equal(nrow(A), 1) expect_true(checkLatinHypercube(A)) }) lhs/tests/testthat/test-optseededlhs.R0000644000176200001440000000262613423214206017630 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-optseededlhs") test_that("optseededLHS works", { expect_error(optSeededLHS(randomLHS(10, 4), NA)) expect_error(optSeededLHS(randomLHS(10, 4), NaN)) expect_error(optSeededLHS(randomLHS(10, 4), Inf)) expect_error(optSeededLHS(randomLHS(10, 4), 2, NA)) expect_error(optSeededLHS(randomLHS(10, 4), 2, NaN)) expect_warning(expect_error(optSeededLHS(randomLHS(10, 4), 2, Inf))) expect_error(optSeededLHS(randomLHS(10, 4), 2, 5, NA)) expect_error(optSeededLHS(randomLHS(10, 4), 2, 5, NaN)) expect_error(optSeededLHS(randomLHS(10, 4), 2, 5, Inf)) temp <- randomLHS(10, 4) temp[1,1] <- NA expect_error(optSeededLHS(temp, 5)) temp <- randomLHS(10, 4) temp[1,1] <- 2 expect_error(optSeededLHS(temp, 5)) set.seed(1976) A <- optSeededLHS(randomLHS(4, 2), 2) expect_true(checkLatinHypercube(A)) set.seed(1977) B <- optSeededLHS(randomLHS(3, 3), 3, 3, .05) expect_true(checkLatinHypercube(B)) A <- optSeededLHS(randomLHS(10, 4), m = 0) expect_true(checkLatinHypercube(A)) expect_error(.Call("optSeededLHS_cpp", 3, 4L, 4L, 0.01, matrix(1L, 2, 2), FALSE)) X <- .Call("optSeededLHS_cpp", 1L, 4L, 4L, 0.01, matrix(runif(4), nrow = 1, ncol = 4), FALSE) expect_equal(nrow(X), 1) expect_true(checkLatinHypercube(X)) expect_error(.Call("optSeededLHS_cpp", 3L, 4L, 4L, 0.01, matrix(1L, 2, 2), FALSE)) }) lhs/tests/testthat/test-oa_to_oalhs.R0000644000176200001440000000525213425356377017454 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-oa_to_oalhs") test_that("oa_to_oalhs works with internal oa generation", { oa <- createBose(3, 4, TRUE) oalhs <- oa_to_oalhs(9, 4, oa) expect_true(checkLatinHypercube(oalhs)) oa <- createBose(3, 4, FALSE) oalhs <- oa_to_oalhs(9, 4, oa) expect_true(checkLatinHypercube(oalhs)) oa <- createBoseBush(8, 5, TRUE) oalhs <- oa_to_oalhs(128, 5, oa) expect_true(checkLatinHypercube(oalhs)) # check a mismatch in n causes an error expect_error(oa_to_oalhs(3, 5, oa)) # check a mismatch in k causes an error expect_error(oa_to_oalhs(128, 8, oa)) # check a wrong sized oa causes an error expect_error(oa_to_oalhs(128, 5, oa[1:100,1:3])) # check wrong type expect_error(oa_to_oalhs(3, 5, matrix(1.2, nrow = 3, ncol = 5))) oa <- createAddelKemp(3, 4, FALSE) oalhs <- oa_to_oalhs(18, 4, oa) expect_true(checkLatinHypercube(oalhs)) oa <- createAddelKemp3(4, 20, TRUE) oalhs <- oa_to_oalhs(128, 20, oa) expect_true(checkLatinHypercube(oalhs)) expect_error(.Call("oa_to_lhs", 4, 20L, oa, FALSE)) expect_error(.Call("oa_to_lhs", 4L, 20L, oa, 5)) expect_error(.Call("oa_to_lhs", as.integer(NA), 20L, oa, FALSE)) }) test_that("oa_to_oalhs works with DoE.base", { # note: trying to ensure that a lack of DoE.base does not break the tests # also trying to avoid attaching the DoE.base package because it causes warnings in the test suite testthat::skip_if_not_installed("DoE.base") # 12 rows, two columns of 1,2 and one column of 1:6 my_oa <- DoE.base::oa.design(ID = DoE.base::L12.2.2.6.1) oalhs <- oa_to_oalhs(12, 3, my_oa) expect_true(checkLatinHypercube(oalhs)) # 20 rows, 19 columns of 1,2 my_oa <- DoE.base::oa.design(ID = DoE.base::L20.2.19) oalhs <- oa_to_oalhs(20, 19, my_oa) expect_true(checkLatinHypercube(oalhs)) # can I get the oa back? #c(ifelse(floor(oalhs*20) < 20/2, 1, 2)) == as.integer(as.matrix(my_oa)) # can I verify that the oalhs is an oa? temp <- t(ifelse(floor(oalhs*20) < 20/2, -1, 1)) %*% ifelse(floor(oalhs*20) < 20/2, -1, 1) expect_true(all(temp[upper.tri(temp)] == 0)) # 20 rows, 19 columns of 1,2 my_oa <- DoE.base::oa.design(ID = DoE.base::L9.3.4) oalhs <- oa_to_oalhs(9, 4, my_oa) expect_true(checkLatinHypercube(oalhs)) # can I verify that the oalhs is an oa? temp1 <- ifelse(floor(oalhs*9) < 9/3, -1, ifelse(floor(oalhs*9) < 2*9/3, 0, 1)) temp <- t(temp1) %*% temp1 expect_true(all(temp[upper.tri(temp)] == 0)) }) test_that("Edge cases", { A <- matrix(1L, nrow = 1, ncol = 4) B <- oa_to_oalhs(1, 4, A) expect_equal(nrow(B), 1) expect_true(checkLatinHypercube(B)) }) lhs/tests/testthat/test-create_oalhs.R0000644000176200001440000000252613420500406017572 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-create_oalhs") test_that("create_oalhs works", { oalhs <- create_oalhs(9, 4, TRUE, FALSE) expect_true(checkLatinHypercube(oalhs)) expect_equal(nrow(oalhs), 9) expect_equal(ncol(oalhs), 4) # ask for an achievable design oalhs <- create_oalhs(4, 2, TRUE, FALSE) expect_true(checkLatinHypercube(oalhs)) expect_equal(nrow(oalhs), 4) expect_equal(ncol(oalhs), 2) # ask for a design that needs more rows oalhs <- create_oalhs(20, 3, TRUE, FALSE) expect_true(checkLatinHypercube(oalhs)) expect_equal(nrow(oalhs), 25) expect_equal(ncol(oalhs), 3) # ask for a design but ask for less rows oalhs <- create_oalhs(20, 3, FALSE, FALSE) expect_true(checkLatinHypercube(oalhs)) expect_equal(nrow(oalhs), 18) expect_equal(ncol(oalhs), 3) oalhs <- create_oalhs(20, 10, TRUE, FALSE) expect_true(checkLatinHypercube(oalhs)) expect_equal(nrow(oalhs), 54) expect_equal(ncol(oalhs), 10) # check repeatability set.seed(1001) X <- create_oalhs(9, 4, TRUE, FALSE) set.seed(1001) Y <- create_oalhs(9, 4, TRUE, FALSE) expect_true(all(X == Y)) expect_error(.Call("create_oalhs", 3, 4L, FALSE, FALSE)) expect_error(.Call("create_oalhs", 3L, 4L, 5, FALSE)) expect_error(.Call("create_oalhs", 3L, as.integer(NA), FALSE, FALSE)) }) lhs/tests/testthat/test-optaugmentlhs.R0000644000176200001440000000203313423216603020032 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-optaugmentlhs") test_that("optAugmentLHS works", { expect_error(optAugmentLHS(randomLHS(10, 4), NA)) expect_error(optAugmentLHS(randomLHS(10, 4), NaN)) expect_error(optAugmentLHS(randomLHS(10, 4), Inf)) expect_error(optAugmentLHS(randomLHS(10, 4), 2, NA)) expect_error(optAugmentLHS(randomLHS(10, 4), 2, NaN)) expect_error(optAugmentLHS(randomLHS(10, 4), 2, Inf)) temp <- randomLHS(10, 4) temp[1,1] <- NA expect_error(optAugmentLHS(temp, 5)) temp <- randomLHS(10, 4) temp[1,1] <- 2 expect_error(optAugmentLHS(temp, 5)) set.seed(1976) expect_true(checkLatinHypercube(optAugmentLHS(randomLHS(4, 2), 2))) set.seed(1977) expect_true(checkLatinHypercube(optAugmentLHS(randomLHS(3, 3), 3, 3))) expect_error(optAugmentLHS(c(1,2), m = 4, mult = 2)) expect_error(optAugmentLHS(randomLHS(10, 4), c(1,2))) expect_error(optAugmentLHS(randomLHS(10, 4), -2)) A <- optAugmentLHS(randomLHS(1,4), 1) expect_true(checkLatinHypercube(A)) }) lhs/tests/testthat/test-maximinlhs.R0000644000176200001440000000561013423215572017321 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-maximinlhs") test_that("maximinLHS works", { expect_error(maximinLHS(-1, 2)) expect_error(maximinLHS(10, -30)) expect_error(maximinLHS(10, 2, dup = -2)) expect_error(maximinLHS(NA, 2)) expect_error(maximinLHS(NaN, 2)) expect_warning(expect_error(maximinLHS(Inf, 2))) expect_error(maximinLHS(10, NA)) expect_error(maximinLHS(10, NaN)) expect_warning(expect_error(maximinLHS(10, Inf))) expect_error(maximinLHS(10, 2, dup = NA)) expect_error(maximinLHS(10, 2, dup = NaN)) expect_warning(expect_error(maximinLHS(10, 2, dup = Inf))) set.seed(1976) expect_true(checkLatinHypercube(maximinLHS(4, 2))) set.seed(1977) expect_true(checkLatinHypercube(maximinLHS(3, 3, dup = 5))) expect_error(maximinLHS(10, 4, method = "none")) expect_error(maximinLHS(10, 4, method = "build", optimize.on = "none")) expect_warning(maximinLHS(10, 4, method = "build", optimize.on = "result")) expect_error(maximinLHS(10, c(4,5), method = "iterative")) expect_error(maximinLHS(10, NA, method = "iterative")) expect_error(maximinLHS(10, Inf, method = "iterative")) expect_error(maximinLHS(12.2, 4, method = "iterative")) expect_error(maximinLHS(12, 4.3, method = "iterative")) expect_error(maximinLHS(12, 4, dup = 10.2, method = "iterative")) A <- maximinLHS(12, 4, dup = 10, method = "iterative", optimize.on = "result") expect_true(checkLatinHypercube(A)) A <- maximinLHS(20, 5, dup = 3, method = "iterative", optimize.on = "grid") expect_true(checkLatinHypercube(A)) A <- maximinLHS(1, 4) expect_equal(nrow(A), 1) expect_true(checkLatinHypercube(A)) }) test_that("maximinLHS works with expanded capability", { expect_true(checkLatinHypercube(maximinLHS(4, 3, method = "build", dup = 2))) expect_true(checkLatinHypercube(maximinLHS(4, 3, method = "iterative", eps = 0.05, maxIter = 100, optimize.on = "grid"))) expect_true(checkLatinHypercube(maximinLHS(4, 3, method = "iterative", eps = 0.05, maxIter = 100, optimize.on = "result"))) }) test_that("maximinLHS debug capability for code coverage", { capture_output(X <- maximinLHS(10, 4, method = "build", optimize.on = "grid", debug = TRUE)) expect_equal(nrow(X), 10) expect_warning(capture_output(X <- maximinLHS(10, 4, method = "build", optimize.on = "result", debug = TRUE))) expect_equal(nrow(X), 10) capture_output(X <- maximinLHS(10, 10, method = "iterative", optimize.on = "result", eps = 1E-9, debug = TRUE)) expect_equal(nrow(X), 10) capture_output(X <- maximinLHS(5, 5, method = "iterative", optimize.on = "result", eps = 1, debug = TRUE)) expect_error(.Call("maximinLHS_cpp", 3, 4L, 4L)) X <- .Call("maximinLHS_cpp", 1L, 4L, 4L) expect_equal(nrow(X), 1) }) lhs/tests/testthat/test-augmentlhs.R0000644000176200001440000000247313423214555017323 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-augmentlhs") test_that("augment works", { expect_error(augmentLHS(randomLHS(10, 4), NA)) expect_error(augmentLHS(randomLHS(10, 4), NaN)) expect_error(augmentLHS(randomLHS(10, 4), Inf)) set.seed(1976) temp <- randomLHS(10, 4) temp[1,1] <- NA expect_error(augmentLHS(temp, 5)) set.seed(1976) temp <- randomLHS(10, 4) temp[1,1] <- 2 expect_error(augmentLHS(temp, 5)) set.seed(1976) expect_true(checkLatinHypercube(augmentLHS(randomLHS(4, 2), 4))) set.seed(1977) expect_true(checkLatinHypercube(augmentLHS(randomLHS(3, 3), 3))) set.seed(1977) expect_true(checkLatinHypercube(augmentLHS(randomLHS(4, 1), 2))) # this test addresses a bug where an error ocurred on adding 1 row in # augmentLHS temp <- randomLHS(7, 2) temp <- augmentLHS(temp, 1) expect_equal(nrow(temp), 8) expect_true(checkLatinHypercube(augmentLHS(randomLHS(7, 2), 7))) expect_true(checkLatinHypercube(augmentLHS(randomLHS(10, 5), 10))) # test exceptions expect_error(augmentLHS(c(1,2), 5)) expect_error(augmentLHS(randomLHS(10,3), c(5,9))) expect_error(augmentLHS(randomLHS(10,3), -1)) expect_error(augmentLHS(randomLHS(10,3), 2.2)) A <- augmentLHS(randomLHS(1,4), 1) expect_true(checkLatinHypercube(A)) }) lhs/src/0000755000176200001440000000000013425401602011624 5ustar liggesuserslhs/src/Makevars0000644000176200001440000000005013425401602013313 0ustar liggesusersPKG_CPPFLAGS=-DRCOMPILE CXX_STD = CXX11 lhs/src/oa_r_utils.cpp0000644000176200001440000000303213425401602014466 0ustar liggesusers/** * @file oa_r_utils.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #include "oa_r_utils.h" namespace oarutils { void randomizeOA(Rcpp::IntegerMatrix & oa, int q) { // get the random number scope from R Rcpp::RNGScope scope; size_t rows = oa.rows(); size_t cols = oa.cols(); Rcpp::NumericVector perm; std::vector ranks(q); // Permute the symbols in each column for (size_t j = 0; j < cols; j++) { perm = Rcpp::runif(q); oacpp::rutils::findranks_zero(Rcpp::as >(perm), ranks); for (size_t i = 0; i < rows; i++) { oa(i,j) = ranks[oa(i,j)]; } } } } // end namespace lhs/src/akconst.cpp0000644000176200001440000000640713425401602014001 0ustar liggesusers/** * @file akconst.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "ak.h" namespace oacpp { namespace oaaddelkemp { /* Find constants for Addelman Kempthorne designs when q is even. */ int akeven(GF & gf, int* kay, std::vector & b, std::vector & c, std::vector & k) { size_t q = static_cast(gf.q); if (q > 4) { std::string msg = "Addelman Kempthorne designs not yet available for \n even q >4."; throw std::runtime_error(msg.c_str()); } *kay = 1; if (q == 2) { b[1] = c[1] = k[1] = 1; } if (q == 4) { b[1] = c[1] = 2; b[2] = c[2] = 1; b[3] = c[3] = 3; k[1] = 1; k[2] = 2; k[3] = 3; } // TODO: isn't this redundant to the above for q <= 4 for (size_t i = 1; i < q; i++) { k[i] = static_cast(i); } return 0; } int akodd(GF & gf, int* kay, std::vector & b, std::vector & c, std::vector & k) { int num, den, four; size_t q = static_cast(gf.q); size_t p = static_cast(gf.p); if (p != 3) { four = 4; } else { four = 1; } *kay = 0; for (size_t i = 2; i < q; i++) { if (gf.root[i] == -1) { *kay = static_cast(i); } } if (*kay == 0) { std::ostringstream s; s << "Problem: no rootless element in GF(" << gf.n << ").\n"; const std::string ss = s.str(); throw std::runtime_error(ss.c_str()); } for (size_t i = 1; i < q; i++) { num = gf.plus(*kay,p - 1); /* -1 = +(p-1) */ den = gf.times(*kay,four); den = gf.times(den,i); b[i] = gf.times(num,gf.inv[den]); k[i] = gf.times(*kay,i); c[i] = gf.times(i,i); c[i] = gf.times(c[i],num); c[i] = gf.times(c[i],gf.inv[four]); } return 0; } } // end namespace } // end namespace lhs/src/primes.h0000644000176200001440000000427113425401602013300 0ustar liggesusers/** * @file primes.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef PRIMES_H #define PRIMES_H #include "OACommonDefines.h" /** * Macro to indicate that a number is prime */ #define ISPRIMETRUE 1 /** * Macro to indicate that a number is not prime */ #define ISPRIMEFALSE 0 namespace oacpp { /** * Utilities related to prime numbers */ namespace primes { /** * returns 1 for prime argument * @param n number to test * @return 1 if p is prime */ int isprime(unsigned int n); /** * Is the number prime * @deprecated due to slowness * @param p number * @return 1 if prime, 0 otherwise */ int isprime_old(int p); /** * find q=p^n if q is a prime power with n>0 * @param q integer that is a prime power * @param p the prime base * @param n the integer power * @param isit an indicator of completion */ void primepow(int q, int* p, int* n, int* isit); /** * returns 1 for prime power argument * @param q * @return */ int isprimepow(int q ); /** * pow() with integer arguments and value * @param a * @param b * @return */ int ipow( int a, int b ); } // end namespace }// end namespace #endif lhs/src/geneticLHS.cpp0000644000176200001440000002257613425401602014331 0ustar liggesusers/** * @file geneticLHS.cpp * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #include "LHSCommonDefines.h" #include "utilityLHS.h" namespace lhslib { // TODO: multi-thread the iterations over population void geneticLHS(int n, int k, int pop, int gen, double pMut, std::string criterium, bool bVerbose, bclib::matrix & result, bclib::CRandom & oRandom) { if (n < 1 || k < 1) { throw std::runtime_error("nsamples are less than 1 (n) or nparameters less than 1 (k)"); } msize_type m_n = static_cast(n); msize_type m_k = static_cast(k); if (result.rowsize() != m_n || result.colsize() != m_k) { throw std::runtime_error("result should be n x k for the lhslib::geneticLHS call"); } if (gen < 1 || pop < 1) { throw std::invalid_argument("pop, and gen should be integers greater than 0"); } msize_type m_pop = static_cast(pop); msize_type m_gen = static_cast(gen); if (pMut <= 0 || pMut >= 1) { throw std::invalid_argument("pMut should be between 0 and 1"); } if (m_pop % 2 != 0) { throw std::invalid_argument("pop should be an even number"); } std::vector > A = std::vector >(m_pop); for (msize_type i = 0; i < m_pop; i++) { A[i] = bclib::matrix(m_n, m_k); } for (msize_type i = 0; i < m_pop; i++) { // fill A with random hypercubes randomLHS(static_cast(m_n), static_cast(m_k), A[i], oRandom); #ifdef _DEBUG if (!lhslib::isValidLHS(A[i])) PRINT_MACRO("A is not valid at %d in randomLHS\n", static_cast(i)); #endif } std::vector B; std::vector > J; bclib::matrix dist; std::vector::iterator it; std::vector distnonzero = std::vector(); for (msize_type v = 0; v < m_gen; v++) { B = std::vector(m_pop); for (msize_type i = 0; i < m_pop; i++) { if (criterium == "S") { B[i] = calculateSOptimal(A[i]); } else if (criterium == "Maximin") { //B[i] <- min(dist(A[, , i])) dist = bclib::matrix(A[i].rowsize(), A[i].rowsize()); calculateDistance(A[i], dist); // we want to find the minimum distance element, but there are zeros in the dist matrix distnonzero.clear(); for (bclib::matrix::const_iterator mit = dist.begin(); mit != dist.end(); ++mit) { if (*mit > 0.0) { distnonzero.push_back(*mit); } } it = std::min_element(distnonzero.begin(), distnonzero.end()); B[i] = *it; } else { std::stringstream msg; msg << "Criterium not recognized: S and Maximin are available: " << criterium.c_str() << " was provided.\n"; const std::string smsg = msg.str(); throw std::invalid_argument(smsg.c_str()); } } // H is used as an index on vector of matrices, A, so it should be using zero based order std::vector H = std::vector(B.size()); bclib::findorder_zero(B, H); int posit = static_cast(std::max_element(B.begin(), B.end()) - B.begin()); J = std::vector >(m_pop); for (std::vector >::iterator i = J.begin(); i != J.end(); ++i) { *i = bclib::matrix(m_n, m_k); } #ifdef _DEBUG if (!lhslib::isValidLHS(A[posit])) PRINT_MACRO("A is not valid at %d in randomLHS\n", static_cast(posit)); #endif // the first half of the next population gets the best hypercube from the first population for (msize_type i = 0; i < (m_pop / 2); i++) { J[i] = A[posit]; } if (m_pop / 2 == 1) { break; } // the second half of the next population gets the decreasingly best hypercubes from the first population for (msize_type i = 0; i < (m_pop / 2); i++) { J[i + m_pop / 2] = A[H[i]]; #ifdef _DEBUG if (!lhslib::isValidLHS(J[i + m_pop / 2])) { PRINT_MACRO("J is not valid at %d %d %d in 2nd half setup\n", static_cast(i + m_pop / 2), static_cast(i), static_cast(m_pop/2)); PRINT_MACRO("J is equal to A[H[i]], 1 is true %d", (int)(J[i+m_pop/2] == A[H[i]])); PRINT_MACRO("\n%s\n", J[i + m_pop / 2].toString()); PRINT_MACRO("\n%s\n", A[H[i]].toString()); PRINT_MACRO("H: "); for (vsize_type iv = 0; iv < H.size(); iv++) { PRINT_MACRO("%d,", H[iv]); } PRINT_MACRO("\n"); return; } #endif } int temp1, temp2; // skip the first best hypercube in the next generation // in the others in the first half of the population, randomly permute a column from the second half into the first half for (msize_type i = 1; i < (m_pop / 2); i++) { runifint(0, static_cast(m_k)-1, &temp1, oRandom); runifint(0, static_cast(m_k)-1, &temp2, oRandom); for (msize_type irow = 0; irow < m_n; irow++) { J[i](irow, temp1) = J[i + m_pop / 2](irow, temp2); } #ifdef _DEBUG if (!lhslib::isValidLHS(J[i])) { PRINT_MACRO("J is not valid at %d in 1st half permute\n", static_cast(i)); PRINT_MACRO("\n%s\n", J[i].toString()); return; } #endif } // for the second half of the population, randomly permute a column from the best hypercube for (msize_type i = m_pop / 2; i < m_pop; i++) { runifint(0, static_cast(m_k)-1, &temp1, oRandom); runifint(0, static_cast(m_k)-1, &temp2, oRandom); for (msize_type irow = 0; irow < m_n; irow++) { J[i](irow, temp1) = A[posit](irow, temp2); } if (!lhslib::isValidLHS(J[i])) PRINT_MACRO << "J is not valid at " << i << " in second half permute\n"; } // randomly exchange two numbers in pMut percent of columns std::vector y = std::vector(m_k); for (msize_type i = 1; i < m_pop; i++) { runif_std(static_cast(m_k), y, oRandom); for (msize_type j = 0; j < m_k; j++) { if (y[j] <= pMut) { std::vector z = std::vector(2); runifint(2u, 0, static_cast(m_n-1), z, oRandom); int a = J[i](z[0], j); int b = J[i](z[1], j); J[i](z[0], j) = b; J[i](z[1], j) = a; } } } // put all of J back into A to start the next round A = J; if (v != m_gen && bVerbose) { PRINT_MACRO << "Generation " << v << " completed\n"; // LCOV_EXCL_LINE } } if (bVerbose) { PRINT_MACRO << "Last generation completed\n"; // LCOV_EXCL_LINE } #ifdef _DEBUG if (!lhslib::isValidLHS(J[0])) PRINT_MACRO("J[0] is not valid\n"); #endif std::vector eps = std::vector(m_n*m_k); runif_std(static_cast(m_n * m_k), eps, oRandom); unsigned int count = 0; for (unsigned int j = 0; j < static_cast(m_k); j++) { for (unsigned int i = 0; i < static_cast(m_n); i++) { result(i,j) = (static_cast(J[0](i,j)) - 1.0 + eps[count]) / static_cast(m_n); count++; } } } } lhs/src/primes.cpp0000644000176200001440000000777113425401602013643 0ustar liggesusers/** * @file primes.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "primes.h" namespace oacpp { namespace primes { int isprime_old(int p) // LCOV_EXCL_START { if (p < 2) { return ISPRIMEFALSE; } /* This is not the fastest, but it is likely to take negligible time compared to that used in constructing the Galois field or the experimental design */ double maxDivisor = sqrt(static_cast(p + 1)); for (int k = 2; static_cast(k) < maxDivisor; k++) { if ((p / k) * k == p) { return ISPRIMEFALSE; } } return ISPRIMETRUE; } // LCOV_EXCL_STOP int isprime(unsigned int n) { // 0, 1 if (n < 2) { return ISPRIMEFALSE; } // 2, 3 if (n < 4) { return ISPRIMETRUE; } // if n is divisible by 2, it is not prime // 4,6,8,10,... if (n % 2 == 0) { return ISPRIMEFALSE; } // 5 => sqrt(5)=2.1 => iMax=3 => i=3 => 5%3!=0 => prime // 7 => sqrt(7)=2.5 => iMax=3 => i=3 => 7%3!=0 => prime // 9 => sqrt(9)=3 => iMax=3 => i=3 => 9%3=0 => not prime size_t iMax = static_cast(sqrt(static_cast(n))) + 1; for (size_t i = 3; i <= iMax; i += 2) { if (n % i == 0) { return ISPRIMEFALSE; } } return ISPRIMETRUE; } void primepow(int q, int* p, int* n, int* isit) { int firstfactor = 0; // maybe uninitialized otherwise *p = *n = *isit = 0; if (q <= 1) { return; } if (isprime(q)) { *p = q; *n = 1; *isit = 1; return; } for (int k = 2; k < sqrt(static_cast(q) + 1.0); k++) { if ((q % k) == 0) { firstfactor = k; break; } } if (!isprime(firstfactor)) // LCOV_EXCL_START { return; } // LCOV_EXCL_STOP while (1) { if (q == 1) { *isit = 1; *p = firstfactor; return; } if (q % firstfactor == 0) { *n += 1; q /= firstfactor; } else { return; } } } int isprimepow(int q) { int p, n, ispp; primepow(q, &p, &n, &ispp); return ispp; } int ipow(int a, int b) { return (int) pow((double) a, (double) b); } } // end namespace } // end namespace lhs/src/construct.h0000644000176200001440000001046513425401602014027 0ustar liggesusers/** * @file construct.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef CONSTRUCT_H #define CONSTRUCT_H /* Constructions for designs using Galois fields */ #include "OACommonDefines.h" #include "galois.h" #include "ak.h" /* Glossary: */ namespace oacpp { /** * Namespace to construct Orthogonal Arrays using various algorithms */ namespace oaconstruct { /** * Construct an orthogonal array using the bose algorithm * * OA( q^2, q+1, q, 2 ) * R.C. Bose (1938) Sankhya Vol 3 pp 323-338 * * @param gf galois field * @param A an orthogonal array * @param ncol the number of columns * @return an indicator of success */ int bose(GF & gf, bclib::matrix & A, int ncol ); /** * Construct an orthogonal array using the bush algorithm * @param gf * @param A * @param str * @param ncol * @return */ int bush(GF & gf, bclib::matrix & A, int str, int ncol ); /** * * Implement Addelman and Kempthorne's 1961 A.M.S. method with n=2 * * @param gf * @param A * @param ncol * @return */ int addelkemp(GF & gf, bclib::matrix & A, int ncol ); /** * Construct an orthogonal array using the bosebush algorithm * * OA( 2q^2, 2q+1, q, 2 ), only implemented for q=2^n * Implement Bose and Bush's 1952 A.M.S. method with p=2, u=1 * * @param gf * @param B * @param ncol * @return */ int bosebush(GF & gf, bclib::matrix & B, int ncol ); /** * Construct an orthogonal array using the bose-bush algorithm * * @param gf * @param lam * @param B * @param ncol * @return */ int bosebushl(GF & gf, int lam, bclib::matrix & B, int ncol ); /** * Check the input to the bose algorithm * @param q the number of symbols * @param ncol the number of columns * @return an indicator of success */ int bosecheck(int q, int ncol ); /** * * @param n * @param q * @param d * @param coef * @return */ int itopoly(int n, int q, int d, std::vector & coef ); /** * Evaluate a polynomial with coefficients, argument and result in a Galois field * @param gf a Galois field * @param d * @param poly * @param arg * @param value * @return */ int polyeval(GF & gf, int d, std::vector & poly, int arg, int* value ); /** * * @param q * @param str * @param ncol * @return */ int bushcheck(int q, int str, int ncol); /** * * @param q * @param p * @param ncol * @return */ int bosebushcheck(int q, int p, int ncol ); /** * * @param s * @param p * @param lam * @param ncol * @return */ int bosebushlcheck(int s, int p, int lam, int ncol ); /** * * @param q * @param p * @param ncol * @return */ int addelkempcheck(int q, int p, int ncol ); } }// end namespace #endif lhs/src/optimumLHS.cpp0000644000176200001440000002542013425401602014374 0ustar liggesusers/** * @file optimumLHS.cpp * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #include "LHSCommonDefines.h" #include "utilityLHS.h" /* * Arrays are passed into this routine to allow R to allocate and deallocate * memory within the wrapper function. * * Dimensions: oldHypercube N x K * optimalityRecordLength = N choose 2 + 1 * Parameters: * N: The number of points to be sampled * K: The number of dimensions (or variables) needed * maxSweeps: The maximum number of times the exchange algorithm * is applied across the columns. Therefor if * MAXSWEEPS =5 and K = 6 then 30 exchange operations * could be used. * eps: The minimum fraction gained in optimality that is * desired to continue the iterations as a fraction of * the gain from the first interchange * References: Please see the package documentation * */ namespace lhslib { /* * Return an optimized hypercube according to the criteria given * */ void optimumLHS(int n, int k, int maxSweeps, double eps, bclib::matrix & outlhs, int optimalityRecordLength, bclib::CRandom & oRandom, bool bVerbose) { if (n < 1 || k < 1 || maxSweeps < 1 || eps <= 0) { throw std::runtime_error("nsamples or nparameters or maxSweeps are less than 1 or eps <= 0"); } unsigned int nOptimalityRecordLength = static_cast(optimalityRecordLength); msize_type nsamples = static_cast(n); msize_type nparameters = static_cast(k); unsigned int nMaxSweeps = static_cast(maxSweeps); double eps_change = eps; int extraColumns = 0; double gOptimalityOld; double optimalityChangeOld = 0.0; double optimalityChange; int test; unsigned int iter, posit, optimalityRecordIndex; if (outlhs.rowsize() != nsamples || outlhs.colsize() != nparameters) { outlhs = bclib::matrix(nsamples, nparameters); } //matrix_unsafe oldHypercube_new = matrix_unsafe(nsamples, nparameters, oldHypercube, true); bclib::matrix newHypercube = bclib::matrix(nsamples, nparameters); std::vector optimalityRecord = std::vector(nOptimalityRecordLength); std::vector interchangeRow1 = std::vector(nOptimalityRecordLength); std::vector interchangeRow2 = std::vector(nOptimalityRecordLength); // fill the oldHypercube with a random lhs sample std::vector randomUnif(nsamples); std::vector orderedUnif(nsamples); for (msize_type jcol = 0; jcol < nparameters; jcol++) { // fill a vector with a random sample to order for (msize_type irow = 0; irow < nsamples; irow++) { randomUnif[irow] = oRandom.getNextRandom(); } bclib::findorder(randomUnif, orderedUnif); for (msize_type irow = 0; irow < nsamples; irow++) { outlhs(irow,jcol) = orderedUnif[irow]; } } /* find the initial optimality measure */ gOptimalityOld = sumInvDistance(outlhs); if (bVerbose) { PRINT_MACRO << "Beginning Optimality Criterion " << gOptimalityOld << " \n"; // LCOV_EXCL_LINE } #if PRINT_RESULT lhsPrint(outlhs, 1); #endif test = 0; iter = 0; while (test == 0) { if (iter == nMaxSweeps) { break; } iter++; /* iterate over the columns */ for (msize_type j = 0; j < nparameters; j++) { optimalityRecordIndex = 0; /* iterate over the rows for the first point from 0 to N-2 */ for (msize_type i = 0; i < (nsamples - 1); i++) { /* iterate over the rows for the second point from i+1 to N-1 */ for (msize_type kindex = (i + 1); kindex < nsamples; kindex++) { /* put the values from oldHypercube into newHypercube */ copyMatrix(newHypercube, outlhs); /* exchange two values (from the ith and kth rows) in the jth column * and place them in the new matrix */ newHypercube(i, j) = outlhs(kindex, j); newHypercube(kindex, j) = outlhs(i, j); /* store the optimality of the newly created matrix and the rows that * were interchanged */ optimalityRecord[optimalityRecordIndex] = sumInvDistance(newHypercube); interchangeRow1[optimalityRecordIndex] = static_cast(i); interchangeRow2[optimalityRecordIndex] = static_cast(kindex); optimalityRecordIndex++; } } /* once all combinations of the row interchanges have been completed for * the current column j, store the old optimality measure (the one we are * trying to beat) */ optimalityRecord[optimalityRecordIndex] = gOptimalityOld; interchangeRow1[optimalityRecordIndex] = 0; interchangeRow2[optimalityRecordIndex] = 0; /* Find which optimality measure is the lowest for the current column. * In other words, which two row interchanges made the hypercube better in * this column */ posit = 0; for (vsize_type kindex = 0; kindex < nOptimalityRecordLength; kindex++) { if (optimalityRecord[kindex] < optimalityRecord[posit]) { posit = static_cast(kindex); } } /* If the new minimum optimality measure is better than the old measure */ if (optimalityRecord[posit] < gOptimalityOld) { /* put oldHypercube in newHypercube */ copyMatrix(newHypercube, outlhs); /* Interchange the rows that were the best for this column */ newHypercube(interchangeRow1[posit], j) = outlhs(interchangeRow2[posit], j); newHypercube(interchangeRow2[posit], j) = outlhs(interchangeRow1[posit], j); /* put newHypercube back in oldHypercube for the next iteration */ copyMatrix(outlhs, newHypercube); /* if this is not the first column we have used for this sweep */ if (j > 0) { /* check to see how much benefit we gained from this sweep */ optimalityChange = std::fabs(optimalityRecord[posit] - gOptimalityOld); if (optimalityChange < eps_change * optimalityChangeOld) { test = 1; if (bVerbose) { PRINT_MACRO << "Algorithm stopped when the change in the inverse distance measure was smaller than " << ((eps_change)* optimalityChangeOld) << " \n"; // LCOV_EXCL_LINE } } } /* if this is first column of the sweep, then store the benefit gained */ else { optimalityChangeOld = std::fabs(optimalityRecord[posit] - gOptimalityOld); } /* replace the old optimality measure with the current one */ gOptimalityOld = optimalityRecord[posit]; } /* if the new and old optimality measures are equal */ else if (optimalityRecord[posit] == gOptimalityOld) { test = 1; if (bVerbose) { PRINT_MACRO << "Algorithm stopped when changes did not improve design optimality\n"; // LCOV_EXCL_LINE } } /* if the new optimality measure is worse */ else if (optimalityRecord[posit] > gOptimalityOld) // LCOV_EXCL_START { ERROR_MACRO << "Unexpected Result: Algorithm produced a less optimal design\n"; test = 1; } // LCOV_EXCL_STOP /* if there is a reason to exit... */ if (test == 1) { break; } extraColumns++; } } /* if we made it through all the sweeps */ if (iter == nMaxSweeps) { if (bVerbose) { PRINT_MACRO << nMaxSweeps << " full sweeps completed\n"; // LCOV_EXCL_LINE } } /* if we didn't make it through all of them */ else { if (bVerbose) { PRINT_MACRO << "Algorithm used " << (iter-1) << " sweep(s) and " << extraColumns << " extra column(s)\n"; // LCOV_EXCL_LINE } } if (bVerbose) { PRINT_MACRO << "Final Optimality Criterion " << gOptimalityOld << " \n"; // LCOV_EXCL_LINE } //#if _DEBUG bool btest = isValidLHS(outlhs); if (!btest) { /* the error function should send an error message through R */ ERROR_MACRO << "Invalid Hypercube\n"; // LCOV_EXCL_LINE } //#endif #if PRINT_RESULT lhsPrint(outlhs, 1); #endif } } // end namespace lhs/src/COrthogonalArray.cpp0000644000176200001440000002235313425401602015553 0ustar liggesusers/** * @file COrthogonalArray.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . * * Reference: * */ #include "COrthogonalArray.h" namespace oacpp { COrthogonalArray::COrthogonalArray() { m_nrow = 0; m_ncol = 0; m_q = 0; } void COrthogonalArray::createGaloisField(int q) { bool test = galoisfield::GF_getfield(q, m_gf) == SUCCESS_CHECK ? true : false; if (!test) { throw std::runtime_error("Could not construct the Galois field"); // LCOV_EXCL_TEST } } void COrthogonalArray::checkDesignMemory() { if (m_A.isEmpty()) { throw std::runtime_error("Could not allocate array for the design memory."); // LCOV_EXCL_TEST } } int COrthogonalArray::checkMaxColumns(int k, int maxColumns) { if (k < 2) { return maxColumns; } else if (k > maxColumns) { std::ostringstream s; s << "At most " << maxColumns << "columns are possible for the design."; const std::string ss = s.str(); throw std::runtime_error(ss.c_str()); } else { return k; } } void COrthogonalArray::checkResult(int result, int nvalue, int * n) { if (result) { *n = nvalue; } else { throw std::runtime_error("Unable to construct design"); // LCOV_EXCL_TEST } } void COrthogonalArray::addelkemp(int q, int k, int* n) { k = checkMaxColumns(k, 2*q+1); createGaloisField(q); int matrows = 2 * q * q; m_A = bclib::matrix(matrows, k); checkDesignMemory(); int result = oaconstruct::addelkemp(m_gf, m_A, k); checkResult(result, 2*q*q, n); m_q = q; m_ncol=k; m_nrow=*n; } void COrthogonalArray::addelkemp3(int q, int k, int* n) { k = checkMaxColumns(k, 2*q*q + 2*q + 1); /* 2(q^3-1)/(q-1) - 1 */ createGaloisField(q); int matrows = 2 * q * q * q; m_A = bclib::matrix(static_cast(matrows), k); checkDesignMemory(); int result = oaaddelkemp::addelkemp3(m_gf, m_A, k); checkResult(result, 2*q*q*q, n); m_q = q; m_ncol=k; m_nrow=*n; } void COrthogonalArray::addelkempn(int akn, int q, int k, int* n) // LCOV_EXCL_START { k = checkMaxColumns(k, 2*(primes::ipow(q,akn)-1)/(q-1) - 1); /* 2(q^3-1)/(q-1) - 1 */ createGaloisField(q); int matrows = 2 * primes::ipow(q, akn); m_A = bclib::matrix(matrows, k); checkDesignMemory(); int result = oaaddelkemp::addelkempn(m_gf, akn, m_A, k); checkResult(result, 2*primes::ipow(q,akn), n); m_q = q; m_ncol=k; m_nrow=*n; } // LCOV_EXCL_STOP void COrthogonalArray::bose(int q, int k, int* n) { k = checkMaxColumns(k, q+1); createGaloisField(q); int matrows = q * q; m_A = bclib::matrix(matrows, k); checkDesignMemory(); int result = oaconstruct::bose(m_gf, m_A, k); checkResult(result, q*q, n); m_q = q; m_ncol=k; m_nrow=*n; } void COrthogonalArray::bosebush(int q, int k, int *n) { if (q%2) { throw std::runtime_error("This implementation of Bose-Bush only works for a number of levels equal to a power of 2"); } k = checkMaxColumns(k, 2*q); createGaloisField(2*q); int matrows = 2 * q * q; m_A = bclib::matrix(matrows, k); checkDesignMemory(); int result = oaconstruct::bosebush(m_gf, m_A, k); checkResult(result, 2*q*q, n); m_q = q; m_ncol=k; m_nrow=*n; } void COrthogonalArray::bosebushl(int lambda, int q, int k, int* n) { int pq, nq, isppq, pl, nl, isppl; k = checkMaxColumns(k, q*lambda); primes::primepow(lambda, &pl, &nl, &isppl); primes::primepow(q , &pq, &nq, &isppq); if (!isppq) { throw std::runtime_error("The Bose-Bush design requires that q be prime raised to a positive integral power."); } if (!isppl) { throw std::runtime_error("The Bose-Bush design requires that lambda be a prime raised to a positive integral power."); } if (pl != pq) { throw std::runtime_error("The Bose-Bush design requires that lambda and q be powers of the same prime."); } createGaloisField(lambda*q); int matrows = lambda * q * q; m_A = bclib::matrix(matrows, k); checkDesignMemory(); int result = oaconstruct::bosebushl(m_gf, lambda, m_A, k); checkResult(result, lambda*q*q, n); m_q = q; m_ncol=k; m_nrow=*n; } void COrthogonalArray::bush(int q, int k, int* n) { k = checkMaxColumns(k, q+1); createGaloisField(q); int matrows = q * q * q; m_A = bclib::matrix(matrows, k); checkDesignMemory(); int result = oaconstruct::bush(m_gf, m_A, 3, k); checkResult(result, q*q*q, n); m_q = q; m_ncol=k; m_nrow=*n; } void COrthogonalArray::busht(int str, int q, int k, int* n) { k = checkMaxColumns(k, q+1); if (str < 2) { throw std::runtime_error("Bush designs not provided for strength < 2"); } createGaloisField(q); m_A = bclib::matrix(primes::ipow(q,str), k); checkDesignMemory(); int result = oaconstruct::bush(m_gf, m_A, str, k); checkResult(result, primes::ipow(q,str), n); m_q = q; m_ncol=k; m_nrow=*n; } int COrthogonalArray::oaagree(bool verbose) { int agree, maxagr; int mrow1, mrow2; maxagr = mrow1 = mrow2 = 0; for (int i = 0; i < m_nrow; i++) { for (int j = i+1; j < m_nrow; j++) { agree = 0; for (int k = 0; k < m_ncol; k++) { agree += (m_A(i,k) == m_A(j,k)); } if (agree > maxagr) { maxagr = agree; mrow1 = i; mrow2 = j; if (verbose) { PRINT_OUTPUT << "New max " << i << " " << j << " " << agree << "\n"; // LCOV_EXCL_LINE } } } if (i && i % ROWCHECK == 0 && verbose) { PRINT_OUTPUT << "Checked rows <= " << i << " vs all other rows.\n"; // LCOV_EXCL_LINE } } if (verbose) // LCOV_EXCL_START { if (maxagr == 0) { PRINT_OUTPUT << "No two distinct rows agree in any columns.\n"; } else { PRINT_OUTPUT << "Maximum number of columns matching for two distinct rows is " << maxagr << ".\n"; PRINT_OUTPUT << "This is attained by rows " << mrow1 << " and " << mrow2 << ".\n"; } } // LCOV_EXCL_STOP return maxagr; } int COrthogonalArray::oatriple(bool verbose) { /* Count triple agreements among rows of an array */ int a3/*, q*/; int num3 = 0; for (int j1 = 0; j1 < m_ncol; j1++) { for (int j2 = j1+1; j2 < m_ncol; j2++) { for (int j3 = j2+1; j3 < m_ncol; j3++) { a3 = 0; for (int i1 = 0; i1 < m_nrow; i1++) { for (int i2 = i1+1; i2 < m_nrow; i2++) { a3 += ( m_A(i1,j1)==m_A(i2,j1) )&&( m_A(i1,j2)==m_A(i2,j2) )&&( m_A(i1,j3)==m_A(i2,j3) ); } if (a3) { if (verbose) { PRINT_OUTPUT << "Cols " << j1 << " " << j2 << " " << j3 << " match in " << a3 << " distinct pairs of rows.\n"; // LCOV_EXCL_LINE } num3++; } } } } } if (verbose) // LCOV_EXCL_START { PRINT_OUTPUT << "There are " << num3 << " distinct triples of columns that agree\n"; PRINT_OUTPUT << "in at least two distinct rows.\n"; } // LCOV_EXCL_STOP return num3; } void COrthogonalArray::oarand(int is, int js, int ks, int ls) { m_randomClass.seed(is, js, ks, ls); std::vector pi = std::vector(m_q); for (int j = 0; j < m_ncol; j++) { rutils::unifperm(pi, m_q, m_randomClass); for (int i = 0; i < m_nrow; i++) { m_A(i,j) = pi[ m_A(i,j) ]; } } } int COrthogonalArray::oastr(bool verbose) { int str; int bverb = (verbose) ? ALLMESSAGES : NOMESSAGES; oastrength::OA_strength(m_q, m_A, &str, bverb); if (verbose) // LCOV_EXCL_START { if (str < 0) { PRINT_OUTPUT << "\nThe array does not even have strength 0, meaning that\n"; PRINT_OUTPUT << "it is not composed of symbols 0 through " << m_q << ".\n"; } else { PRINT_OUTPUT << "\nThe array has strength " << str << " and no higher strength.\n"; } } // LCOV_EXCL_STOP return str; } bool COrthogonalArray::oastr1(bool verbose) { int bverb = (verbose) ? ALLMESSAGES : NOMESSAGES; return (oastrength::OA_str1(m_q, m_A, bverb) == SUCCESS_CHECK); } bool COrthogonalArray::oastr2(bool verbose) { int bverb = (verbose) ? ALLMESSAGES : NOMESSAGES; return (oastrength::OA_str2(m_q, m_A, bverb) == SUCCESS_CHECK); } bool COrthogonalArray::oastr3(bool verbose) { int bverb = (verbose) ? ALLMESSAGES : NOMESSAGES; return (oastrength::OA_str3(m_q, m_A, bverb) == SUCCESS_CHECK); } bool COrthogonalArray::oastr4(bool verbose) { int bverb = (verbose) ? ALLMESSAGES : NOMESSAGES; return (oastrength::OA_str4(m_q, m_A, bverb) == SUCCESS_CHECK); } bool COrthogonalArray::oastrt(int t, bool verbose) { int bverb = (verbose) ? ALLMESSAGES : NOMESSAGES; return (oastrength::OA_strt(m_q, m_A, t, bverb) == SUCCESS_CHECK); } } // end namespace lhs/src/utilityLHS.cpp0000644000176200001440000000615513425401602014411 0ustar liggesusers/** * @file utilityLHS.cpp * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #include "utilityLHS.h" namespace lhslib { bool isValidLHS(const bclib::matrix & result) { int total = 0; msize_type cols = result.colsize(); msize_type rows = result.rowsize(); /* * verify that the result is a latin hypercube. One easy check is to ensure * that the sum of the rows is the sum of the 1st N integers. This check can * be fooled in one unlikely way... * if a column should be 1 2 3 4 6 8 5 7 9 10 * the sum would be 10*11/2 = 55 * the same sum could come from 5 5 5 5 5 5 5 5 5 10 * but this is unlikely */ // sum each column for (msize_type jcol = 0; jcol < cols; jcol++) { total = 0; for (msize_type irow = 0; irow < rows; irow++) { total += result(irow, jcol); } if (total != static_cast(rows * (rows + 1) / 2)) { return false; } } return true; } bool isValidLHS(const bclib::matrix & result) { msize_type n = result.rowsize(); msize_type k = result.colsize(); bclib::matrix resultint = bclib::matrix(n, k); bclib::matrix::const_iterator it = result.begin(); bclib::matrix::iterator iti = resultint.begin(); for (;it != result.end(); ++it, ++iti) { *iti = 1 + static_cast(floor(static_cast(n) * (*it))); } bool ret = isValidLHS(resultint); return ret; } void initializeAvailableMatrix(bclib::matrix & avail) { // avail is k x n for (msize_type irow = 0; irow < avail.rowsize(); irow++) { for (msize_type jcol = 0; jcol < avail.colsize(); jcol++) { avail(irow, jcol) = static_cast(jcol + 1); } } } void runif_std(unsigned int n, std::vector & output, bclib::CRandom & oRandom) { if (output.size() != n) { output.resize(n); } for (unsigned int i = 0; i < n; i++) { output[i] = oRandom.getNextRandom(); } } } // end namespace lhs/src/optSeededLHS.cpp0000644000176200001440000002402713425401602014620 0ustar liggesusers/** * @file optSeededLHS.cpp * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #include "LHSCommonDefines.h" #include "utilityLHS.h" /* * Arrays are passed into this routine to allow R to allocate and deallocate * memory within the wrapper function. * This code uses ISO C90 comment styles and layout * * "oldHypercube", "newHypercube", and "matrix" are matricies but are treated as one * dimensional arrays to facilitate passing them from R. * Dimensions: oldHypercube N x K * optimalityRecordLength = N choose 2 + 1 * Parameters: * N: The number of points to be sampled * K: The number of dimensions (or variables) needed * maxSweeps: The maximum number of times the exchange algorithm * is applied across the columns. Therefor if * MAXSWEEPS =5 and K = 6 then 30 exchange operations * could be used. * eps: The minimum fraction gained in optimality that is * desired to continue the iterations as a fraction of * the gain from the first interchange * References: Please see the package documentation * */ namespace lhslib { /* * Return an optimized hypercube according to the criteria given * */ void optSeededLHS(int n, int k, int maxSweeps, double eps, bclib::matrix & oldHypercube, int optimalityRecordLength, bool bVerbose) { if (n < 1 || k < 1 || maxSweeps < 1 || eps <= 0) { throw std::runtime_error("nsamples or nparameters or maxSweeps are less than 1 or eps <= 0"); } unsigned int nOptimalityRecordLength = static_cast(optimalityRecordLength); msize_type nsamples = static_cast(n); msize_type nparameters = static_cast(k); unsigned int nMaxSweeps = static_cast(maxSweeps); double eps_change = eps; int extraColumns = 0; double gOptimalityOld; double optimalityChangeOld = 0.0; double optimalityChange; int test; unsigned int iter, posit, optimalityRecordIndex; //matrix_unsafe oldHypercube_new = matrix_unsafe(nsamples, nparameters, oldHypercube, true); bclib::matrix newHypercube = bclib::matrix(nsamples, nparameters); std::vector optimalityRecord = std::vector(nOptimalityRecordLength); std::vector interchangeRow1 = std::vector(nOptimalityRecordLength); std::vector interchangeRow2 = std::vector(nOptimalityRecordLength); /* find the initial optimality measure */ gOptimalityOld = sumInvDistance(oldHypercube); if (bVerbose) { PRINT_MACRO << "Beginning Optimality Criterion " << gOptimalityOld << " \n"; // LCOV_EXCL_LINE } #if PRINT_RESULT lhslib::lhsPrint(oldHypercube, false); #endif test = 0; iter = 0; while (test == 0) { if (iter == nMaxSweeps) { break; } iter++; /* iterate over the columns */ for (msize_type j = 0; j < nparameters; j++) { optimalityRecordIndex = 0; /* iterate over the rows for the first point from 0 to N-2 */ for (msize_type i = 0; i < nsamples - 1; i++) { /* iterate over the rows for the second point from i+1 to N-1 */ for (msize_type kindex = i + 1; kindex < nsamples; kindex++) { /* put the values from oldHypercube into newHypercube */ copyMatrix(newHypercube, oldHypercube); /* exchange two values (from the ith and kth rows) in the jth column * and place them in the new matrix */ newHypercube(i, j) = oldHypercube(kindex, j); newHypercube(kindex, j) = oldHypercube(i, j); /* store the optimality of the newly created matrix and the rows that * were interchanged */ optimalityRecord[optimalityRecordIndex] = sumInvDistance(newHypercube); interchangeRow1[optimalityRecordIndex] = static_cast(i); interchangeRow2[optimalityRecordIndex] = static_cast(kindex); optimalityRecordIndex++; } } /* once all combinations of the row interchanges have been completed for * the current column j, store the old optimality measure (the one we are * trying to beat) */ optimalityRecord[optimalityRecordIndex] = gOptimalityOld; interchangeRow1[optimalityRecordIndex] = 0; interchangeRow2[optimalityRecordIndex] = 0; /* Find which optimality measure is the lowest for the current column. * In other words, which two row interchanges made the hypercube better in * this column */ posit = 0; for (vsize_type kindex = 0; kindex < nOptimalityRecordLength; kindex++) { if (optimalityRecord[kindex] < optimalityRecord[posit]) { posit = static_cast(kindex); } } /* If the new minimum optimality measure is better than the old measure */ if (optimalityRecord[posit] < gOptimalityOld) { /* put oldHypercube in newHypercube */ copyMatrix(newHypercube, oldHypercube); /* Interchange the rows that were the best for this column */ newHypercube(interchangeRow1[posit], j) = oldHypercube(interchangeRow2[posit], j); newHypercube(interchangeRow2[posit], j) = oldHypercube(interchangeRow1[posit], j); /* put newHypercube back in oldHypercube for the next iteration */ copyMatrix(oldHypercube, newHypercube); /* if this is not the first column we have used for this sweep */ if (j > 0) { /* check to see how much benefit we gained from this sweep */ optimalityChange = std::fabs(optimalityRecord[posit] - gOptimalityOld); if (optimalityChange < eps_change * optimalityChangeOld) { test = 1; if (bVerbose) { PRINT_MACRO << "Algorithm stopped when the change in the inverse distance measure was smaller than " << ((eps_change)* optimalityChangeOld) << " \n"; // LCOV_EXCL_LINE } } } /* if this is first column of the sweep, then store the benefit gained */ else { optimalityChangeOld = std::fabs(optimalityRecord[posit] - gOptimalityOld); } /* replace the old optimality measure with the current one */ gOptimalityOld = optimalityRecord[posit]; } /* if the new and old optimality measures are equal */ else if (optimalityRecord[posit] == gOptimalityOld) { test = 1; if (bVerbose) { PRINT_MACRO << "Algorithm stopped when changes did not impove design optimality\n"; // LCOV_EXCL_LINE } } /* if the new optimality measure is worse */ else if (optimalityRecord[posit] > gOptimalityOld) // LCOV_EXCL_START { ERROR_MACRO << "Unexpected Result: Algorithm produced a less optimal design\n"; test = 1; } // LCOV_EXCL_STOP /* if there is a reason to exit... */ if (test == 1) { break; } extraColumns++; } } /* if we made it through all the sweeps */ if (iter == nMaxSweeps) { if (bVerbose) { PRINT_MACRO << nMaxSweeps << " full sweeps completed\n"; // LCOV_EXCL_LINE } } /* if we didn't make it through all of them */ else { if (bVerbose) { PRINT_MACRO << "Algorithm used " << (iter-1) << " sweep(s) and " << extraColumns << " extra column(s)\n"; // LCOV_EXCL_LINE } } if (bVerbose) { PRINT_MACRO << "Final Optimality Criterion " << gOptimalityOld << " \n"; // LCOV_EXCL_LINE } #if PRINT_RESULT lhsPrint(oldHypercube, false); #endif } } // end namespace lhs/src/lhs_r.cpp0000644000176200001440000001713713425401602013450 0ustar liggesusers/** * @file lhs_r.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #include "lhs_r.h" RcppExport SEXP /*double matrix*/ improvedLHS_cpp(SEXP /*int*/ n, SEXP /*int*/ k, SEXP /*int*/ dup) { BEGIN_RCPP if (TYPEOF(n) != INTSXP || TYPEOF(k) != INTSXP || TYPEOF(dup) != INTSXP) { Rcpp_error("n, k, and dup should be integers"); } Rcpp::RNGScope tempRNG; int m_n = Rcpp::as(n); int m_k = Rcpp::as(k); int m_dup = Rcpp::as(dup); lhs_r::checkArguments(m_n, m_k, m_dup); lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { return lhs_r::degenerateCase(m_k, oRStandardUniform); } bclib::matrix intMat = bclib::matrix(m_n, m_k); lhslib::improvedLHS(m_n, m_k, m_dup, intMat, oRStandardUniform); Rcpp::NumericMatrix result = lhs_r::convertIntegerToNumericLhs(intMat); return result; END_RCPP } RcppExport SEXP /*double matrix*/ maximinLHS_cpp(SEXP /*int*/ n, SEXP /*int*/ k, SEXP /*int*/ dup) { BEGIN_RCPP if (TYPEOF(n) != INTSXP || TYPEOF(k) != INTSXP || TYPEOF(dup) != INTSXP) { Rcpp_error("n, k, and dup should be integers"); } Rcpp::RNGScope tempRNG; int m_n = Rcpp::as(n); int m_k = Rcpp::as(k); int m_dup = Rcpp::as(dup); lhs_r::checkArguments(m_n, m_k, m_dup); lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { return lhs_r::degenerateCase(m_k, oRStandardUniform); } bclib::matrix intMat = bclib::matrix(m_n, m_k); lhslib::maximinLHS(m_n, m_k, m_dup, intMat, oRStandardUniform); Rcpp::NumericMatrix result = lhs_r::convertIntegerToNumericLhs(intMat); return result; END_RCPP } RcppExport SEXP /*double matrix*/ optimumLHS_cpp(SEXP /*int*/ n, SEXP /*int*/ k, SEXP /*int*/ maxsweeps, SEXP /*double*/ eps, SEXP /*bool*/ bVerbose) { BEGIN_RCPP if (TYPEOF(n) != INTSXP || TYPEOF(k) != INTSXP || TYPEOF(maxsweeps) != INTSXP || TYPEOF(eps) != REALSXP || TYPEOF(bVerbose) != LGLSXP) { Rcpp_error("n, k, and maxsweeps should be integers, eps should be a real, and bVerbose should be a logical"); } int m_n = Rcpp::as(n); int m_k = Rcpp::as(k); int m_maxsweeps = Rcpp::as(maxsweeps); double m_eps = Rcpp::as(eps); bool m_bVerbose = Rcpp::as(bVerbose); lhs_r::checkArguments(m_n, m_k, m_maxsweeps, m_eps); Rcpp::RNGScope tempRNG; lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { return lhs_r::degenerateCase(m_k, oRStandardUniform); } int jLen = static_cast(::Rf_choose(static_cast(m_n), 2.0) + 1.0); bclib::matrix intMat = bclib::matrix(m_n, m_k); lhslib::optimumLHS(m_n, m_k, m_maxsweeps, m_eps, intMat, jLen, oRStandardUniform, m_bVerbose); Rcpp::NumericMatrix result = lhs_r::convertIntegerToNumericLhs(intMat); return result; END_RCPP } RcppExport SEXP /*double matrix*/ optSeededLHS_cpp(SEXP /*int*/ n, SEXP /*int*/ k, SEXP /*int*/ maxsweeps, SEXP /*double*/ eps, SEXP /*numeric matrix*/ inlhs, SEXP /*bool*/ bVerbose) { BEGIN_RCPP if (TYPEOF(n) != INTSXP || TYPEOF(k) != INTSXP || TYPEOF(maxsweeps) != INTSXP || TYPEOF(eps) != REALSXP || TYPEOF(bVerbose) != LGLSXP) { Rcpp_error("n, k, and maxsweeps should be integers, eps should be a real, and bVerbose should be a logical"); } int m_n = Rcpp::as(n); int m_k = Rcpp::as(k); int m_maxsweeps = Rcpp::as(maxsweeps); double m_eps = Rcpp::as(eps); bool m_bVerbose = Rcpp::as(bVerbose); lhs_r::checkArguments(m_n, m_k, m_maxsweeps, m_eps); Rcpp::NumericMatrix m_inlhs(inlhs); if (m_inlhs.ncol() != m_k || m_inlhs.nrow() != m_n) { Rcpp_error("input matrix does not match the n and k arguments"); } if (m_n == 1) { return m_inlhs; } int jLen = static_cast(::Rf_choose(static_cast(m_n), 2.0) + 1.0); //std::vector mv_inlhs = Rcpp::as >(m_inlhs); // this probably unrolled the matrix columnwise //bclib::matrix mm_inlhs = bclib::matrix(m_n, m_k, mv_inlhs); // and this was row wise bclib::matrix mm_inlhs = bclib::matrix(m_n, m_k); for (int i = 0; i < m_n; i++) { for (int j = 0; j < m_k; j++) { mm_inlhs(i,j) = m_inlhs(i,j); } } lhslib::optSeededLHS(m_n, m_k, m_maxsweeps, m_eps, mm_inlhs, jLen, m_bVerbose); Rcpp::NumericMatrix result = lhs_r::convertMatrixToNumericLhs(mm_inlhs); return result; END_RCPP } RcppExport SEXP randomLHS_cpp(SEXP n, SEXP k, SEXP preserveDraw) { BEGIN_RCPP if (TYPEOF(n) != INTSXP || TYPEOF(k) != INTSXP || TYPEOF(preserveDraw) != LGLSXP) { Rcpp_error("n and k should be integers, preserveDraw should be a logical"); } Rcpp::RNGScope tempRNG; int m_n = Rcpp::as(n); int m_k = Rcpp::as(k); bool bPreserveDraw = Rcpp::as(preserveDraw); lhs_r::checkArguments(m_n, m_k); lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { return lhs_r::degenerateCase(m_k, oRStandardUniform); } bclib::matrix result = bclib::matrix(m_n, m_k); lhslib::randomLHS(m_n, m_k, bPreserveDraw, result, oRStandardUniform); Rcpp::NumericMatrix rresult(m_n, m_k); for (int irow = 0; irow < m_n; irow++) { for (int jcol = 0; jcol < m_k; jcol++) { rresult(irow, jcol) = result(irow, jcol); } } return rresult; END_RCPP } RcppExport SEXP geneticLHS_cpp(SEXP /*int*/ n, SEXP /*int*/ k, SEXP /*int*/ pop, SEXP /*int*/ gen, SEXP /*double*/ pMut, SEXP criterium, SEXP /*bool*/ bVerbose) { BEGIN_RCPP Rcpp::RNGScope tempRNG; int m_n = Rcpp::as(n); int m_k = Rcpp::as(k); int m_pop = Rcpp::as(pop); int m_gen = Rcpp::as(gen); double m_pMut = Rcpp::as(pMut); std::string m_criterium = Rcpp::as(criterium); bool m_bVerbose = Rcpp::as(bVerbose); lhs_r::checkArguments(m_n, m_k); lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { return lhs_r::degenerateCase(m_k, oRStandardUniform); } bclib::matrix mat = bclib::matrix(m_n, m_k); lhslib::geneticLHS(m_n, m_k, m_pop, m_gen, m_pMut, m_criterium, m_bVerbose, mat, oRStandardUniform); Rcpp::NumericMatrix rresult(m_n, m_k); for (int irow = 0; irow < m_n; irow++) { for (int jcol = 0; jcol < m_k; jcol++) { rresult(irow, jcol) = mat(irow, jcol); } } return rresult; END_RCPP } lhs/src/construct.cpp0000644000176200001440000003677213425401602014373 0ustar liggesusers/** * @file construct.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "construct.h" namespace oacpp { namespace oaconstruct { int bosecheck(int q, int ncol) { std::ostringstream msg; if (ncol > q + 1) { msg << "Bose's design must have ncol <= q+1. Had q=" << q << " and ncol=" << ncol << ".\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (ncol <= 0) { msg << "Nonpositive number of columns requested for Bose's design\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } return SUCCESS_CHECK; } int bose(GF & gf, bclib::matrix & A, int ncol) { size_t icol, irow; size_t q = static_cast(gf.q); // bosecheck throws if it fails bosecheck(static_cast(q), ncol); irow = 0; for (size_t i = 0; i < q; i++) { for (size_t j = 0; j < q; j++) { icol = 0; A(irow, icol++) = static_cast(i); if (ncol > 1) { A(irow, icol++) = static_cast(j); } for (icol = 2; icol < static_cast(ncol); icol++) { A(irow, icol) = gf.plus(j, gf.times(i, icol - 1)); } irow++; } } return SUCCESS_CHECK; } int itopoly(int n, int q, int d, std::vector & coef) { for (size_t i = 0; i <= static_cast(d); i++) { coef[i] = n % q; n = n / q; } return UNCHECKED_RETURN; } /* find value = poly(arg) where poly is a polynomial of degree d and all the arithmetic takes place in the given Galois field.*/ int polyeval(GF & gf, int d, std::vector & poly, int arg, int* value) { int ans = 0; /* note: cannot decrement with a size type because it is always > 0. this needs to go < 1 to stop */ //for (size_t i = static_cast(d); i >= 0; --i) /* Horner's rule */ for (int i = d; i >= 0; i--) /* Horner's rule */ { size_t ui = static_cast(i); size_t uans = static_cast(ans); size_t uarg = static_cast(arg); #ifdef RANGE_DEBUG size_t plusRow = static_cast(gf.times.at(uans,uarg)); size_t plusCol = static_cast(poly.at(ui)); ans = gf.plus.at(plusRow, plusCol); #else //ans = gf.plus(gf.times(ans,arg),poly[i]); size_t plusRow = static_cast(gf.times(uans,uarg)); size_t plusCol = static_cast(poly[ui]); ans = gf.plus(plusRow, plusCol); #endif } *value = ans; return UNCHECKED_RETURN; } int bushcheck(int q, int str, int ncol) { std::ostringstream msg; if (ncol > q + 1) { msg << "Bush designs require ncol <= q+1. Cannot have q = " << q << " and ncol = " << ncol << ".\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (str > ncol) { msg << "It doesn't make sense to have an array of strength " << str << " with only " << ncol << "columns.\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (str >= q + 1) // LCOV_EXCL_START { PRINT_OUTPUT << "\tBush's (1952) theorem has a condition t & A, int str, int ncol) { int q = gf.q; std::vector coef(str); // bushcheck throws if it fails bushcheck(q, str, ncol); for (size_t i = 0; i < static_cast(primes::ipow(q, str)); i++) { itopoly(static_cast(i), q, str - 1, coef); A(i, static_cast(0)) = coef[static_cast(str) - 1]; for (size_t j = 0; j < static_cast(ncol) - 1; j++) { polyeval(gf, str - 1, coef, static_cast(j), &(A(i, 1 + j))); } } return SUCCESS_CHECK; } int addelkempcheck(int q, int p, int ncol) { std::ostringstream msg; if (p == 2 && q > 4) { msg << "This Addelman-Kempthorne OA(2q^2,ncol,q,2) is only\n"; msg << "available for odd prime powers q and for even prime\n"; msg << "powers q<=4. q=" << q << " is not available, but a\n"; msg << "Bose Bush construction exists for that design.\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (ncol > 2 * q + 1) { msg << "The Addelman-Kempthorne construction needs ncol <= 2q+1.\n"; msg << "Can't have ncol = " << ncol << " with q = " << q << ".\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (ncol == 2 * q + 1) // LCOV_EXCL_START { PRINT_OUTPUT << "\n\tWarning: The Addelman-Kempthorne construction with ncol = 2q+1\n"; PRINT_OUTPUT << "\thas a defect. While it is still an OA(2q^2,2q+1,q,2),\n"; PRINT_OUTPUT << "\tthere exist some pairs of rows that agree in three columns.\n"; PRINT_OUTPUT << "\tThe final column in the array is involved in all of these\n"; PRINT_OUTPUT << "\ttriple coincidences.\n"; } // LCOV_EXCL_STOP return SUCCESS_CHECK; } int addelkemp(GF & gf, bclib::matrix & A, int ncol) { int kay; /* A&K notation */ int square, ksquare, temp; size_t row, col; int p = gf.p; size_t q = gf.q; std::vector b(q); std::vector c(q); std::vector k(q); // addelkempcheck throws if it fails addelkempcheck(static_cast(q), p, ncol); for (size_t i = 0; i < q; i++) { /* First q*q rows */ square = gf.times(i,i); for (size_t j = 0; j < q; j++) { row = i * q + j; col = 0; if (col < static_cast(ncol)) { A(row, col++) = static_cast(j); } for (size_t m = 1; m < q && col < static_cast(ncol); m++) { A(row,col++) = gf.plus(i,gf.times(m,j)); } for (size_t m = 0; m < q && col < static_cast(ncol); m++) { temp = gf.plus(j,gf.times(m,i)); A(row,col++) = gf.plus(temp,square); /* Rgt cols */ } if (col < static_cast(ncol)) { A(row, col++) = static_cast(i); } } } if (p != 2) /* Constants kay,b,c,k for odd p */ { oaaddelkemp::akodd(gf, &kay, b, c, k); } else /* Constants kay,b,c,k for even p */ { oaaddelkemp::akeven(gf, &kay, b, c, k); } for (size_t i = 0; i < q; i++) { /* Second q*q rows */ square = gf.times(i,i); ksquare = gf.times(kay,square); for (size_t j = 0; j < q; j++) { row = q * q + i * q + j; col = 0; if (col < static_cast(ncol)) { A(row, col++) = static_cast(j); } for (size_t m = 1; m < q && col < static_cast(ncol); m++, col++) { A(row,col) = gf.plus(A(row - q * q,col),b[m]); } if (col < static_cast(ncol)) { A(row,col++) = gf.plus(ksquare,j); /* q+1 */ } for (size_t m = 1; m < q && col < static_cast(ncol); m++) { temp = gf.times(i,k[m]); temp = gf.plus(ksquare,temp); temp = gf.plus(j,temp); A(row,col++) = gf.plus(temp,c[m]); } if (col < static_cast(ncol)) { A(row, col++) = static_cast(i); } } } return SUCCESS_CHECK; } int bosebushcheck(int q, int p, int ncol) { std::ostringstream msg; if (p != 2) { msg << "This version of Bose and Bush needs q=2^n for some n.\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (ncol > 2 * q + 1) { msg << "The Bose-Bush construction needs ncol <= 2q+1.\n"; msg << "Can't have ncol = " << ncol << " with q = " << q << ".\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (ncol == 2 * q + 1) // LCOV_EXCL_START { PRINT_OUTPUT << "\n\tWarning: The Bose-Bush construction with ncol = 2q+1\n"; PRINT_OUTPUT << "\thas a defect. While it is still an OA(2q^2,2q+1,q,2),\n"; PRINT_OUTPUT << "\tthere exist some pairs of rows that agree in three columns.\n\n"; } // LCOV_EXCL_STOP return SUCCESS_CHECK; } int bosebush(GF & gf, bclib::matrix & B, int ncol) { int p; int mul; size_t irow; p = gf.p; /* GF(q) used to generate design with q/2 levels */ size_t q = static_cast(gf.q); size_t s = q / 2; /* number of levels in design */ bclib::matrix A(s, q); // bosebushcheck throws if it fails bosebushcheck(static_cast(s), p, ncol); irow = 0; for (size_t i = 0; i < q; i++) { for (size_t j = 0; j < q; j++) { mul = gf.times(i,j); mul = mul % s; for (size_t k = 0; k < s; k++) { A(k,j) = gf.plus(mul,k); } } for (size_t k = 0; k < s; k++) { for (size_t j = 0; j < static_cast(ncol) && j < 2 * s + 1; j++) { B(irow,j) = A(k,j); } if (static_cast(ncol) == 2 * s + 1) { B(irow, static_cast(ncol) - 1) = static_cast(i % s); } irow++; } } return SUCCESS_CHECK; } int bosebushlcheck(int s, int p, int lam, int ncol) { std::ostringstream msg; if (!primes::isprime(p)) { msg << "Bose Bush routine given a nonprime.\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (ncol > lam * s + 1) { msg << "The Bose-Bush construction needs ncol <= lambda*q+1.\n"; msg << "Can't have ncol = " << ncol << " with lam = " << lam << "\n"; msg << "and q = " << s << ".\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (ncol == lam * s + 1) // LCOV_EXCL_START { PRINT_OUTPUT << "\n\tWarning: The Bose-Bush construction with ncol = lambda*q+1\n"; PRINT_OUTPUT << "\thas a defect. While it is still an OA(lambda*q^2,lambda*q+1,q,2),\n"; PRINT_OUTPUT << "\tit may have worse coincidence properties than\n"; PRINT_OUTPUT << "\tOA(lambda*q^2,lambda*q+1,q,2).\n"; } // LCOV_EXCL_STOP return SUCCESS_CHECK; } int bosebushl(GF & gf, int lam, bclib::matrix & B, int ncol) /* Implement Bose and Bush's 1952 A.M.S. method with given lambda */ { int p, irow; int mul; p = gf.p; /* GF(q) used to generate design with q/lam levels */ size_t q = static_cast(gf.q); size_t s = q / lam; /* number of levels in design */ bclib::matrix A(s,q); // bosebushlcheck throws if it fails bosebushlcheck(static_cast(s), p, lam, ncol); irow = 0; for (size_t i = 0; i < q; i++) { for (size_t j = 0; j < q; j++) { mul = gf.times(i,j); mul = mul % s; for (size_t k = 0; k < s; k++) { A(k,j) = gf.plus(mul,k); } } for (size_t k = 0; k < s; k++) { for (size_t j = 0; j < static_cast(ncol) && j < lam * s + 1; j++) { B(irow,j) = A(k,j); } if (ncol == lam * static_cast(s) + 1) { B(irow, static_cast(ncol) - 1) = static_cast(i % s); } irow++; } } return SUCCESS_CHECK; } } // end namespace } // end namespace lhs/src/oaLHSUtility.h0000644000176200001440000000300213425401602014322 0ustar liggesusers/* * File: oaLHSUtility.h * Author: carnellr * * Created on March 4, 2014, 10:31 PM */ #ifndef OALHSUTILITY_H #define OALHSUTILITY_H #include namespace oalhslib { /*template void findUnique(typename std::iterator & begin, typename std::iterator & end, typename std::vector & output) { for (std::iterator it = begin; it != end; ++it) { typename std::vector::iterator tempit = std::find(output.begin(), output.end(), *it); if (tempit == output.end()) { output.push_back(*it); } } }*/ template void findUniqueColumnElements(const bclib::matrix & A, std::vector > & U) { if (U.size() != A.colsize()) { U = std::vector >(A.colsize()); } for (typename bclib::matrix::size_type i = 0; i < A.colsize(); i++) { U[i] = std::vector(); for (typename bclib::matrix::const_columnwise_iterator it = A.columnwisebegin(i); it != A.columnwiseend(i); ++it) { typename std::vector::iterator tempit = std::find(U[i].begin(), U[i].end(), *it); if (tempit == U[i].end()) { U[i].push_back(*it); } } } } } #endif /* OALHSUTILITY_H */ lhs/src/oa_r.h0000644000176200001440000000657713425401602012734 0ustar liggesusers/** * @file oa_r.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #ifndef OA_R_H #define OA_R_H #include #include #include #include "COrthogonalArray.h" #include "matrix.h" #include "oa_r_utils.h" /** * An entry point for a set of Orthogonal Array algorithms * * @see oacpp::COrthogonalArray::bose * @see oacpp::COrthogonalArray::bosebush * @see oacpp::COrthogonalArray::bush * @see oacpp::COrthogonalArray::addelkemp * @see oacpp::COrthogonalArray::addelkemp3 * @todo test if q, ncol, n is a vector, Rcpp::as should throw * @todo test of NA's are not caught as expected * @todo test if infinities are not caught as expected * @todo do tests in c++ for all to determine what must be checked in R * @param type The type of orthogonal array algorithm to use
  • bose
  • bosebush
  • bush
  • addelkemp
  • addelkemp3
* @param q the number of symbols in the array * @param ncol the number of columns in the array * @param bRandom whether the array should be randomized * @return an integer matrix */ RcppExport SEXP /*int matrix*/ oa_type1(SEXP /*char*/ type, SEXP /*int*/ q, SEXP /*int*/ ncol, SEXP /*bool*/ bRandom); /** * An entry point for a set of Orthogonal Array algorithms * @see oacpp::COrthogonalArray::busht * @see oacpp::COrthogonalArray::bosebushl * @see oacpp::COrthogonalArray::addelkempn * @param type The type of orthogonal array algorithm to use
  • busht
  • bosebushl
  • addelkempn
* @param int1 a parameter that depends on the context
  • busht: the strength
  • bosebush: lambda
  • addelkemp: the exponent on q
* @param q the number of symbols in the array * @param ncol the number of columns in the array * @param bRandom whether the array should be randomized * @return an integer matrix */ RcppExport SEXP /*int matrix*/ oa_type2(SEXP /*char*/ type, SEXP /*int*/ int1, SEXP /*int*/ q, SEXP /*int*/ ncol, SEXP /*bool*/ bRandom); namespace typeConstants { /** bush algorithm indicator */ const char * BUSH = "bush"; /** bose algorithm indicator */ const char * BOSE = "bose"; /** bosebush algorithm indicator */ const char * BOSEBUSH = "bosebush"; /** busht algorithm indicator */ const char * BUSHT = "busht"; /** bosebushl algorithm indicator */ const char * BOSEBUSHL = "bosebushl"; /** addelkemp algorithm indicator */ const char * ADDELKEMP = "addelkemp"; /** addelkemp3 algorithm indicator */ const char * ADDELKEMP3 = "addelkemp3"; /** addelkempn algorithm indicator */ const char * ADDELKEMPN = "addelkempn"; } // end namespace #endif /* OA_R_H */ lhs/src/galdef.h0000644000176200001440000000273313425401602013224 0ustar liggesusers/** * @file galdef.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef GALDEF_H #define GALDEF_H #include "OACommonDefines.h" #include "matrix.h" namespace oacpp { /** * Struct to define a Galois Field */ struct GF { /** Vector Length */ int n; /** modulus */ int p; /** q */ int q; /** x^n */ std::vector xton; /** inverse polynomial */ std::vector inv; /** negative polynomial */ std::vector neg; /** root */ std::vector root; /** sum field */ bclib::matrix plus; /** product field */ bclib::matrix times; /** polynomial field */ bclib::matrix poly; }; } // end namespace #endif lhs/src/order.h0000644000176200001440000000643413425401602013117 0ustar liggesusers/** * @file order.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #ifndef ORDER_H #define ORDER_H #include #include namespace bclib { /** * Comparison operator to use in the findranks method * @param first the first pair of arguments (value, rank) * @param second the second pair of arguments (value, rank) * @return true if the value in the first argument is less than the value in the second argument */ template bool findranksCompare(const std::pair first, const std::pair second) { return (first.first < second.first); } /** * Find the order of each vector element (zero based) * @tparam T numeric argument that can be ordered * @param v the vector to be ordered * @param order the order of the elements */ template void findorder_zero(const std::vector & v, std::vector & order) { // create a vector of pairs to hold the value and the integer rank std::vector > p(v.size()); typename std::vector::const_iterator vi; typename std::vector >::iterator pi; int position = 0; for (vi = v.begin(), pi = p.begin(); vi != v.end() && pi != p.end(); ++vi, ++pi) { *pi = std::pair(*vi, position); position++; } // if the rank vector is not the right size, resize it (the original values may be lost) if (order.size() != v.size()) { order.resize(v.size()); } // sort the pairs of values std::sort(p.begin(), p.end(), findranksCompare); // take the ranks from the pairs and put them in the rank vector std::vector::iterator oi; for (oi = order.begin(), pi = p.begin(); oi != order.end() && pi != p.end(); ++oi, ++pi) { *oi = pi->second; //order[i] = p[i].second; } } /** * Find the order of each vector element (one based) * @tparam T numeric argument that can be ordered * @param v the vector to be ranked * @param order the order of the elements */ template void findorder(const std::vector & v, std::vector & order) { findorder_zero(v, order); for (std::vector::size_type i = 0; i < order.size(); i++) { order[i] += 1; } } } // end namespace #endif /* ORDER_H */ lhs/src/oa.h0000644000176200001440000000667113425401602012406 0ustar liggesusers/** * @file oa.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef OA_H #define OA_H #include "OACommonDefines.h" #include "primes.h" #include "matrix.h" /** * If more than BIGWORK comparisons are required in * an oacheck routine, then a warning is printed that * a large job is underway. If more than MEDWORK comparisons * are required then intermediate results are printed. * No strength checking beyond strength MAXSTR is done. * Only change it if you implement the higher strength * checks! */ #define BIGWORK 100000000 /** * One tenth of the comparisons of BIGWORK */ #define MEDWORK BIGWORK/10 namespace oacpp { /** * Algorithms to check the strength of an orthogonal array */ namespace oastrength { /** * warn about large work loads in strength checking programs * * @param work * @param str */ void OA_strworkcheck(double work, int str); /** * Calculate and return the strength of the array A. * * Verbose: * - verbose = 0 => No printed output * - verbose = 1 => Only stderr output * - verbose = 2 => Output to both stdout and stderr * * @param q * @param A * @param str * @param verbose */ void OA_strength(int q, bclib::matrix & A, int* str, int verbose); /** * Check strength 0 * @param q * @param A * @param verbose * @return */ int OA_str0(int q, bclib::matrix & A, int verbose); /** * Check strength 1 * @param q * @param A * @param verbose * @return */ int OA_str1(int q, bclib::matrix & A, int verbose); /** * Check strength 2 * @param q * @param A * @param verbose * @return */ int OA_str2(int q, bclib::matrix & A, int verbose); /** * Check strength 3 * @param q * @param A * @param verbose * @return */ int OA_str3(int q, bclib::matrix & A, int verbose); /** * Check strength 4 * @param q * @param A * @param verbose * @return */ int OA_str4(int q, bclib::matrix & A, int verbose); /** * Check an arbitrary strength * @param q * @param A * @param t * @param verbose * @return */ int OA_strt(int q, bclib::matrix & A, int t, int verbose); } }// end namespace #endif lhs/src/rutils.cpp0000644000176200001440000000225013425401602013651 0ustar liggesusers/** * @file rutils.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "rutils.h" namespace oacpp { namespace rutils { void unifperm(std::vector & pi, int q, RUnif & randomClass) { std::vector z(q); randomClass.runif(z, q); findranks_zero(z, pi); } } // end namespace } // end namespace lhs/src/xtndispatch.h0000644000176200001440000001427613425401602014340 0ustar liggesusers/* * NOTE: This file should be excluded from the Doxygen build * * file xtndispatch.h * author Robert Carnell * copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef XTNDISPATCH_H #define XTNDISPATCH_H /* This code was computer generated */ if (q == primes::ipow(2,2)) xtn = xtn2t2; if (q == primes::ipow(2,3)) xtn = xtn2t3; if (q == primes::ipow(2,4)) xtn = xtn2t4; if (q == primes::ipow(2,5)) xtn = xtn2t5; if (q == primes::ipow(2,6)) xtn = xtn2t6; if (q == primes::ipow(2,7)) xtn = xtn2t7; if (q == primes::ipow(2,8)) xtn = xtn2t8; if (q == primes::ipow(2,9)) xtn = xtn2t9; if (q == primes::ipow(2,10)) xtn = xtn2t10; if (q == primes::ipow(2,11)) xtn = xtn2t11; if (q == primes::ipow(2,12)) xtn = xtn2t12; if (q == primes::ipow(2,13)) xtn = xtn2t13; if (q == primes::ipow(2,14)) xtn = xtn2t14; if (q == primes::ipow(2,15)) xtn = xtn2t15; if (q == primes::ipow(2,16)) xtn = xtn2t16; if (q == primes::ipow(2,17)) xtn = xtn2t17; if (q == primes::ipow(2,18)) xtn = xtn2t18; if (q == primes::ipow(2,19)) xtn = xtn2t19; if (q == primes::ipow(2,20)) xtn = xtn2t20; if (q == primes::ipow(2,21)) xtn = xtn2t21; if (q == primes::ipow(2,22)) xtn = xtn2t22; if (q == primes::ipow(2,23)) xtn = xtn2t23; if (q == primes::ipow(2,24)) xtn = xtn2t24; if (q == primes::ipow(2,25)) xtn = xtn2t25; if (q == primes::ipow(2,26)) xtn = xtn2t26; if (q == primes::ipow(2,27)) xtn = xtn2t27; if (q == primes::ipow(2,28)) xtn = xtn2t28; if (q == primes::ipow(2,29)) xtn = xtn2t29; if (q == primes::ipow(3,2)) xtn = xtn3t2; if (q == primes::ipow(3,3)) xtn = xtn3t3; if (q == primes::ipow(3,4)) xtn = xtn3t4; if (q == primes::ipow(3,5)) xtn = xtn3t5; if (q == primes::ipow(3,6)) xtn = xtn3t6; if (q == primes::ipow(3,7)) xtn = xtn3t7; if (q == primes::ipow(3,8)) xtn = xtn3t8; if (q == primes::ipow(3,9)) xtn = xtn3t9; if (q == primes::ipow(3,10)) xtn = xtn3t10; if (q == primes::ipow(3,11)) xtn = xtn3t11; if (q == primes::ipow(3,12)) xtn = xtn3t12; if (q == primes::ipow(3,13)) xtn = xtn3t13; if (q == primes::ipow(3,14)) xtn = xtn3t14; if (q == primes::ipow(3,15)) xtn = xtn3t15; if (q == primes::ipow(3,16)) xtn = xtn3t16; if (q == primes::ipow(3,17)) xtn = xtn3t17; if (q == primes::ipow(3,18)) xtn = xtn3t18; if (q == primes::ipow(5,2)) xtn = xtn5t2; if (q == primes::ipow(5,3)) xtn = xtn5t3; if (q == primes::ipow(5,4)) xtn = xtn5t4; if (q == primes::ipow(5,5)) xtn = xtn5t5; if (q == primes::ipow(5,6)) xtn = xtn5t6; if (q == primes::ipow(5,7)) xtn = xtn5t7; if (q == primes::ipow(5,8)) xtn = xtn5t8; if (q == primes::ipow(5,9)) xtn = xtn5t9; if (q == primes::ipow(5,10)) xtn = xtn5t10; if (q == primes::ipow(5,11)) xtn = xtn5t11; if (q == primes::ipow(5,12)) xtn = xtn5t12; if (q == primes::ipow(7,2)) xtn = xtn7t2; if (q == primes::ipow(7,3)) xtn = xtn7t3; if (q == primes::ipow(7,4)) xtn = xtn7t4; if (q == primes::ipow(7,5)) xtn = xtn7t5; if (q == primes::ipow(7,6)) xtn = xtn7t6; if (q == primes::ipow(7,7)) xtn = xtn7t7; if (q == primes::ipow(7,8)) xtn = xtn7t8; if (q == primes::ipow(7,9)) xtn = xtn7t9; if (q == primes::ipow(7,10)) xtn = xtn7t10; if (q == primes::ipow(11,2)) xtn = xtn11t2; if (q == primes::ipow(11,3)) xtn = xtn11t3; if (q == primes::ipow(11,4)) xtn = xtn11t4; if (q == primes::ipow(11,5)) xtn = xtn11t5; if (q == primes::ipow(11,6)) xtn = xtn11t6; if (q == primes::ipow(11,7)) xtn = xtn11t7; if (q == primes::ipow(11,8)) xtn = xtn11t8; if (q == primes::ipow(13,2)) xtn = xtn13t2; if (q == primes::ipow(13,3)) xtn = xtn13t3; if (q == primes::ipow(13,4)) xtn = xtn13t4; if (q == primes::ipow(13,5)) xtn = xtn13t5; if (q == primes::ipow(13,6)) xtn = xtn13t6; if (q == primes::ipow(13,7)) xtn = xtn13t7; if (q == primes::ipow(13,8)) xtn = xtn13t8; if (q == primes::ipow(17,2)) xtn = xtn17t2; if (q == primes::ipow(17,3)) xtn = xtn17t3; if (q == primes::ipow(17,4)) xtn = xtn17t4; if (q == primes::ipow(17,5)) xtn = xtn17t5; if (q == primes::ipow(17,6)) xtn = xtn17t6; if (q == primes::ipow(17,7)) xtn = xtn17t7; if (q == primes::ipow(19,2)) xtn = xtn19t2; if (q == primes::ipow(19,3)) xtn = xtn19t3; if (q == primes::ipow(19,4)) xtn = xtn19t4; if (q == primes::ipow(19,5)) xtn = xtn19t5; if (q == primes::ipow(19,6)) xtn = xtn19t6; if (q == primes::ipow(19,7)) xtn = xtn19t7; if (q == primes::ipow(23,2)) xtn = xtn23t2; if (q == primes::ipow(23,3)) xtn = xtn23t3; if (q == primes::ipow(23,4)) xtn = xtn23t4; if (q == primes::ipow(23,5)) xtn = xtn23t5; if (q == primes::ipow(23,6)) xtn = xtn23t6; if (q == primes::ipow(29,2)) xtn = xtn29t2; if (q == primes::ipow(29,3)) xtn = xtn29t3; if (q == primes::ipow(29,4)) xtn = xtn29t4; if (q == primes::ipow(29,5)) xtn = xtn29t5; if (q == primes::ipow(29,6)) xtn = xtn29t6; if (q == primes::ipow(31,2)) xtn = xtn31t2; if (q == primes::ipow(31,3)) xtn = xtn31t3; if (q == primes::ipow(31,4)) xtn = xtn31t4; if (q == primes::ipow(31,5)) xtn = xtn31t5; if (q == primes::ipow(31,6)) xtn = xtn31t6; if (q == primes::ipow(37,2)) xtn = xtn37t2; if (q == primes::ipow(37,3)) xtn = xtn37t3; if (q == primes::ipow(37,4)) xtn = xtn37t4; if (q == primes::ipow(37,5)) xtn = xtn37t5; if (q == primes::ipow(41,2)) xtn = xtn41t2; if (q == primes::ipow(41,3)) xtn = xtn41t3; if (q == primes::ipow(41,4)) xtn = xtn41t4; if (q == primes::ipow(41,5)) xtn = xtn41t5; if (q == primes::ipow(43,2)) xtn = xtn43t2; if (q == primes::ipow(43,3)) xtn = xtn43t3; if (q == primes::ipow(43,4)) xtn = xtn43t4; if (q == primes::ipow(43,5)) xtn = xtn43t5; if (q == primes::ipow(47,2)) xtn = xtn47t2; if (q == primes::ipow(47,3)) xtn = xtn47t3; if (q == primes::ipow(47,4)) xtn = xtn47t4; if (q == primes::ipow(47,5)) xtn = xtn47t5; #endif lhs/src/OACommonDefines.h0000644000176200001440000003211413425401602014744 0ustar liggesusers/** * @file OACommonDefines.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . * * Reference: * */ #ifndef OACOMMONDEFINES_H #define OACOMMONDEFINES_H #include #include #include #include #include #include #include #include #include #include #include #ifdef RCOMPILE #include /** * A print macro to enable printing with or without R */ #define PRINT_OUTPUT Rcpp::Rcout #else /** * A print macro to enable printing with or without R */ #define PRINT_OUTPUT std::cout #endif /** * if NDEBUG is not defined, then debug mode is likely enabled */ #ifndef NDEBUG #ifndef RANGE_DEBUG #define RANGE_DEBUG #endif #endif /** * When a method returns an int to indicate success */ #define SUCCESS_CHECK 1 /** * When a method returns an int to indicate failure */ #define FAILURE_CHECK 0 /** * When a method returns an int which is not normally checked */ #define UNCHECKED_RETURN 0 /** * @page oa_main_page Orthogonal Array Library * * From the original documentation by Owen: * *
* From: owen@stat.stanford.edu * * These programs construct and manipulate orthogonal * arrays. They were prepared by * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. * * I thank Randall Tobias of SAS Inc. for many helpful * electronic discussions that lead to improvements in * these programs. *
* * @tableofcontents * * @section orthogonal_arrays_sec Orthogonal Arrays *
* An orthogonal array A is a matrix of n rows, k * columns with every element being one of q symbols * 0,...,q-1. The array has strength t if, in every n by t * submatrix, the q^t possible distinct rows, all appear * the same number of times. This number is the index * of the array, commonly denoted lambda. Clearly, * lambda*q^t = n. Geometrically, if one were to "plot" the * submatrix with one plotting axis for each of the t columns * and one point in t dimensional space for each row, the * result would be a grid of q^t distinct points. There would * be lambda "overstrikes" at each point of the grid. * * The notation for such an array is OA( n, k, q, t ). * * If n <= q^(t+1), then the n rows "should" plot as * n distinct points in every n by t+1 dimensional subarray. * When this fails to hold, the array has the "coincidence * defect". * * Owen (1992,199?) describes some uses for randomized * orthogonal arrays, in numerical integration, computer * experiments and visualization of functions. Those * references contain further references to the literature, * that provide further explanations. A strength 1 randomized * orthogonal array is a Latin hypercube * sample, essentially so or exactly so, depending on * the definition used for Latin hypercube sampling. * The arrays constructed here have strength 2 or more, it * being much easier to construct arrays of strength 1. * * The randomization is achieved by independent * uniform permutation of the symbols in each column. * * To investigate a function f of d variables, one * has to have an array with k >= d. One may also * have a maximum value of n in mind and a minimum value * for the number q of distinct levels to investigate. * * It is entirely possible that no array of strength t > 1 * is compatible with these conditions. The programs * below provide some choices to pick from, hopefully * without too much of a compromise. * * The constructions used are based on published * algorithms that exploit properties of Galois fields. * Because of this the number of levels q must be * a prime power. That is q = p^r where p is prime * and r >= 1 is an integer. * * The Galois field arithmetic for the prime powers is * based on tables published by Knuth and Alanen (1964) * below. The resulting fields have been tested by the * methods described in Appendix 2 of that paper and * they passed. This is more a test of the accuracy of * my transcription than of the original tables. *
* * @section avail_prime_sec Available Prime Powers * *
* The designs given here require a prime power for * the number of levels. They presently work for the * following prime powers: * * All Primes * All prime powers q = p^r where p < 50 and q < 10^9 * * Here are some of the smaller prime powers: * * - Powers of 2: 4 8 16 32 64 128 256 512 * - Powers of 3: 9 27 81 243 729 * - Powers of 5: 25 125 625 * - Powers of 7: 49 343 * - Square of 11: 121 * - Square of 13: 169 * * Here are some useful primes: * * - 2,3,5,7,11,13,17,19,23,29,31,37,101,251,401 * * The first row are small primes, the second row are * primes that are 1 more than a "round number". The small * primes lead to small arrays. An array with 101 levels * is useful for exploring a function at levels 0.00 0.01 * through 1.00. Keep in mind that a strength 2 array on * 101 levels requires 101^2 = 10201 experimental runs, * so it is only useful where large experiments are possible. * * Note that some of these will require more * memory than your computer has. For example, * with a large prime like 10663, the program knows * the Galois field, but can't allocate enough * memory: * * bose 10663 * - Unable to allocate 1927'th row in an integer matrix. * - Unable to allocate space for Galois field on 10663 elements. * - Construction failed for GF(10663). * - Could not construct Galois field needed for Bose design. * * The smallest prime power not covered is 53^2 = 2809. * The smallest strength 2 array with 2809 symbols has * 2809^2 = 7890481 rows. Therefore the missing prime powers * are only needed in certain enormous arrays, not in the * small ones of most practical use. In any event there * are some large primes and prime powers in the program * if an enormous array is needed. * * To add GF(p^r) for some new prime power p^r, * consult Alanen and Knuth for instructions on how * to search for an appropriate indexing polynomial, * and for how to translate that polynomial into a * replacement rule for x^r. *
* * @section methods Methods * *
    *
  • @ref oacpp::COrthogonalArray::bose
    • *
  • @ref oacpp::COrthogonalArray::bush
    • *
  • @ref oacpp::COrthogonalArray::busht
    • *
  • @ref oacpp::COrthogonalArray::bosebush
    • *
  • @ref oacpp::COrthogonalArray::bosebushl
    • *
  • @ref oacpp::COrthogonalArray::addelkemp
    • *
  • @ref oacpp::COrthogonalArray::addelkemp3
    • *
  • @ref oacpp::COrthogonalArray::oarand
    • *
  • @ref oacpp::COrthogonalArray::oastr
    • *
  • @ref oacpp::COrthogonalArray::oastr1
    • *
  • @ref oacpp::COrthogonalArray::oastr2
    • *
  • @ref oacpp::COrthogonalArray::oastr3
    • *
  • @ref oacpp::COrthogonalArray::oastr4
    • *
  • @ref oacpp::COrthogonalArray::oatriple
    • *
  • @ref oacpp::COrthogonalArray::oaagree
    • *
  • @ref oacpp::COrthogonalArray::oadimen
    • *
* * @section tips Tips On Use * *
* It is faster to generate only the columns you need. * For example * bose 101 4 * only generates the first 4 columns of the array, whereas * bose 101 * generates 102 columns. If you only want 4 columns the * former saves a lot of time. * * Passing the q n k on the command line is more difficult * than letting the computer figure them out, but it * allows more error checking. * * In practical use, I would try first to use a Bose * design. Then I would consider either an Addelman- * Kempthorne or Bose-Bush design to see whether it * could accommodate the desired number of columns with * fewer runs. Obviously this advice depends on the * sort of problems I expect to handle. When a very * large number of runs is possible a Bush design may * work well, since it can have high strength. *
* * @section references References * *
* Here are the references for the constructions used: *
    *
  • S. Addelman and O. Kempthorne (1961) Annals of Mathematical Statistics, Vol 32 pp 1167-1176.
    • *
  • J.D. Alanen and D.E. Knuth (1964) Sankhya Ser. A Vol. 26, pp 305-328
    • *
  • R.C. Bose (1938) Sankhya Vol 3 pp 323-338
    • *
  • K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 426-434
    • *
  • R.C. Bose and K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 508-524.
    • *
* This book provides a large list of orthogonal array constructions: *
  • Aloke Dey (1985) "Orthogonal Fractional Factorial Designs" Halstead Press
* * These papers discuss randomized orthogonal arrays, the second * is being revised in parallel with development of the software * described here: *
    *
  • A.B. Owen (1992) Statistica Sinica, v2 n2 pp 439-452
    • *
  • A.B. Owen (199?) Annals of Statistics, to appear "Lattice Sampling Revisited: Monte Carlo Variance of Means Over Randomized Orthogonal Arrays"
    • *
  • H.D. Patterson (1954) J.R.S.S. B 16, 140-149
    • *
* These papers discuss Latin hypercube sampling: *
    *
  • M.D. McKay, W.J. Conover and R.J. Beckman (1979) Technometrics 21, 239-245
    • *
  • A.B. Owen (1992) J.R.S.S. B 541-551
    • *
  • H.D. Patterson (1954) J.R.S.S. B 16, 140-149
    • *
  • M. Stein (1987) Technometrics 29, 143-151
    • *
*
* * @section implement Implementation Details * *
* Galois fields are implemented through arrays that * store their addition and multiplication tables. Some * space could have been saved by using powers of primitive * marks in place of the multiplication table. But since * the multiplication tables itself is only as large as * the smallest possible column in a strength 2 array it * was not considered to be a burden. Subtraction and * division are implemented through vectors of additive * and multiplicative inverses, derived from the tables. * The tables for GF(p^r) are constructed using a * representation of the field elements as polynomials in x * with coefficients as integers modulo p and a special * rule (derived from minimal polynomials) for handling * products involving x^r. These rules are taken from * published references. The rules have not all * been checked for accuracy, because some of the fields are * very large (e.g. 16807 elements). * * The functions that manipulate orthogonal arrays * keep the arrays in integer matrices. This might be * a problem for applications that require enormous * arrays. The reason for keeping them in memory is * that it makes it easier for others to lift out the * functions and embed them in applications or to put * on a GUI front end. It was also thought that any * array that is too large to store in a computer, is * likely to be too large to use in integration/experimentation * on that same computer. The arrays are generated * row by row, so it is not too hard to change the program * to place the elements on an output stream as they * are computed and do away with the storage. * * The functions that test the strength of the * arrays may be very far from optimally fast. *
* * @section compile_oa Compiling oalib * When compiling oalib these preprocessor directives are used: * - NDEBUG defined for a release build * - RCOMPILE defined for building with R */ #endif /* OACOMMONDEFINES_H */ lhs/src/oa_r_utils.h0000644000176200001440000000736413425401602014147 0ustar liggesusers/** * @file oa_r_utils.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #ifndef OA_R_UTILS_H #define OA_R_UTILS_H #include #include #include "matrix.h" #include "rutils.h" /** * @namespace oarutils A namespace for R connection utilities */ namespace oarutils { /** * A method to convert an oacpp::matrix to an Rcpp::IntegerMatrix * @tparam T an atomic type that is convertible to int through a static_cast(T t) * @param A an orthogonal array matrix * @param rcppA the output Rcpp::IntegerMatrix * @return an integer matrix */ template void convertToIntegerMatrix(const bclib::matrix & A, Rcpp::IntegerMatrix & rcppA) { size_t nrows = A.rowsize(); size_t ncols = A.colsize(); if (rcppA.rows() != static_cast(nrows) || rcppA.cols() != static_cast(ncols)) { rcppA = Rcpp::IntegerMatrix(nrows, ncols); } for (size_t i = 0; i < nrows; i++) { for (size_t j = 0; j < ncols; j++) { rcppA(i,j) = static_cast(A(i,j)); } } } /** * A method to convert a bclib::matrix to an Rcpp::NumericMatrix or Rcpp::IntegerMatrix * @tparam T an atomic type that matches the Rcpp type * @tparam U an Rcpp matrix type * @param A a bclib matrix * @param rcppA a Rcpp matrix * @return */ template void convertToRcppMatrix(const bclib::matrix & A, U & rcppA) { size_t nrows = A.rowsize(); size_t ncols = A.colsize(); if (rcppA.rows() != static_cast(nrows) || rcppA.cols() != static_cast(ncols)) { rcppA = U(nrows, ncols); } for (size_t i = 0; i < nrows; i++) { for (size_t j = 0; j < ncols; j++) { rcppA(i,j) = A(i,j); } } } /** * A method to convert a Rcpp::NumericMatrix or Rcpp::IntegerMatrix to a bclib::matrix * @tparam T an atomic type that matches the Rcpp type * @tparam U an Rcpp matrix type * @param A a bclib::matrix * @param rcppA a Rcpp matrix * @return */ template void convertToMatrix(const U & rcppA, bclib::matrix & A) { int nrows = rcppA.rows(); int ncols = rcppA.cols(); if (nrows != static_cast(A.rowsize()) || ncols != static_cast(A.colsize())) { A = bclib::matrix(static_cast(nrows), static_cast(ncols)); } for (size_t i = 0; i < static_cast(nrows); i++) { for (size_t j = 0; j < static_cast(ncols); j++) { A(i,j) = rcppA(i,j); } } } /** * permute the entries of each column in an orthogonal array * @param oa A Rcpp::IntegerMatrix containing an orthogonal array * @param q The number of unique entries in each column */ void randomizeOA(Rcpp::IntegerMatrix & oa, int q); } // end namespace #endif /* OA_R_UTILS_H */ lhs/src/gfields.cpp0000644000176200001440000000646713425401602013762 0ustar liggesusers/** * @file gfields.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "galois.h" namespace oacpp { // include declarations of xtndeclare #include "xtndeclare.h" /** * p^1 */ std::vector xtnpt1; /** * Indicator of whether the Galois fields are set-up */ int GF_fields_are_set = 0; void galoisfield::GF_set_fields() { /* Brute force set up of defining vectors, from Carmichael */ /* Declare x-to-the-power-n vectors, for GFs p-to-the-n */ if (GF_fields_are_set) { PRINT_OUTPUT << "Warning: Fields being re-initialized. Possible memory waste.\n"; // LCOV_EXCL_LINE } // set variables #include "xtnset.h" xtnpt1 = std::vector(1); xtnpt1[0] = 0; GF_fields_are_set = 1; } int galoisfield::GF_getfield(int q, GF & gf) { std::vector xtn; int p, n, ispp; std::ostringstream msg; if (!GF_fields_are_set) { GF_set_fields(); } if (q < 1) { /* Impossible argument */ msg << "Field must have positive number of elements.\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (q == 1) { /* Pointless argument */ msg << "Field with 1 element was requested. \n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } primes::primepow(q, &p, &n, &ispp); if (!ispp) { msg << "q=" << q << " is not a prime power.\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } // include generated code #include "xtndispatch.h" if (primes::isprime(q)) { xtn = xtnpt1; /* Could have tested p=q, or n=1 */ } if (!(xtn.empty())) { if (GF_ready(gf, p, n, xtn)) { return 1; } else // LCOV_EXCL_START { msg << "Construction failed for GF(" << q << ").\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } // LCOV_EXCL_STOP } else { msg << "GF(" << q << ") = GF(" << p << "^" << n << ") is not\n"; msg << "included in this program. To add it, consider modifying gfields.c.\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } return SUCCESS_CHECK; } } // end namespace lhs/src/maximinLHS.cpp0000644000176200001440000002033513425401602014344 0ustar liggesusers/** * @file maximinLHS.cpp * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #include "LHSCommonDefines.h" #include "utilityLHS.h" /* * Arrays are passed into this routine to allow R to allocate and deallocate * memory within the wrapper function. * The R internal random number generator is used that R can set.seed for * testing the functions. * Dimensions: result K x N * Parameters: * N: The number of points to be sampled * K: The number of dimensions (or variables) needed * dup: The duplication factor which affects the number of points * that the optimization algorithm has to choose from * References: Please see the package documentation * */ namespace lhslib { void maximinLHS(int n, int k, int dup, bclib::matrix & result, bclib::CRandom & oRandom) { if (n < 1 || k < 1 || dup < 1) { throw std::runtime_error("nsamples are less than 1 (n) or nparameters less than 1 (k) or duplication is less than 1"); } msize_type nsamples = static_cast(n); msize_type nparameters = static_cast(k); unsigned int duplication = static_cast(dup); if (result.rowsize() != nsamples || result.colsize() != nparameters) { throw std::runtime_error("result should be n x k for the lhslib::maximinLHS call"); } result.transpose(); // ***** matrix_unsafe m_result = matrix_unsafe(nparameters, nsamples, result); /* the length of the point1 columns and the list1 vector */ msize_type len = duplication * (nsamples - 1); /* create memory space for computations */ bclib::matrix avail = bclib::matrix(nparameters, nsamples); bclib::matrix point1 = bclib::matrix(nparameters, len); std::vector list1 = std::vector(len); std::vector vec = std::vector(nparameters); /* squared distance between corner (1,1,1,..) and (N,N,N,...) */ double squaredDistanceBtwnCorners = static_cast(nparameters * (nsamples - 1) * (nsamples - 1)); /* index of the current candidate point */ vsize_type point_index; /* index of the optimum point */ unsigned int best; /* the squared distance between points */ unsigned int distSquared; /* the minimum squared distance between points */ double minSquaredDistBtwnPts; /* The minumum candidate squared difference between points */ unsigned int minCandidateSquaredDistBtwnPts; /* initialize the avail matrix */ initializeAvailableMatrix(avail); /* * come up with an array of K integers from 1 to N randomly * and put them in the last column of result */ for (msize_type irow = 0; irow < nparameters; irow++) { result(irow, nsamples-1) = static_cast(std::floor(oRandom.getNextRandom() * static_cast(nsamples) + 1.0)); } /* * use the random integers from the last column of result to place an N value * randomly through the avail matrix */ for (unsigned int irow = 0; irow < nparameters; irow++) { avail(irow, static_cast(result(irow, nsamples - 1) - 1)) = static_cast(nsamples); } /* move backwards through the result matrix columns */ for (vsize_type ucount = nsamples - 1; ucount > 0; ucount--) { //unsigned int ucount = static_cast(count); for (msize_type irow = 0; irow < nparameters; irow++) { for (msize_type jcol = 0; jcol < duplication; jcol++) { /* create the list1 vector */ for (vsize_type j = 0; j < ucount; j++) { list1[j + ucount*jcol] = avail(irow, j); } } /* create a set of points to choose from */ for (msize_type jcol = ucount * duplication; jcol > 0; jcol--) { point_index = static_cast(std::floor(oRandom.getNextRandom() * static_cast(jcol))); point1(irow, jcol-1) = list1[point_index]; list1[point_index] = list1[jcol - 1]; } } minSquaredDistBtwnPts = DBL_MIN; best = 0; for (msize_type jcol = 0; jcol < duplication * ucount - 1; jcol++) { /* set min candidate equal to the maximum distance to start */ minCandidateSquaredDistBtwnPts = static_cast(std::ceil(squaredDistanceBtwnCorners)); for (msize_type j = ucount; j < nsamples; j++) { distSquared = 0; /* * find the distance between candidate points and the points already * in the sample */ for (msize_type kindex= 0; kindex < nparameters; kindex++) { vec[kindex] = point1(kindex, jcol) - result(kindex, j); distSquared += vec[kindex] * vec[kindex]; } /* * if the distance squared value is the smallest so far, place it in the * min candidate */ if (minCandidateSquaredDistBtwnPts > distSquared) { minCandidateSquaredDistBtwnPts = distSquared; } } /* * if the candidate point is the largest minimum distance between points so * far, then keep that point as the best. */ if (static_cast(minCandidateSquaredDistBtwnPts) > minSquaredDistBtwnPts) { minSquaredDistBtwnPts = static_cast(minCandidateSquaredDistBtwnPts); best = static_cast(jcol); } } /* take the best point out of point1 and place it in the result */ for (msize_type irow = 0; irow < nparameters; irow++) { result(irow, ucount-1) = point1(irow, best); } /* update the numbers that are available for the future points */ for (msize_type irow = 0; irow < nparameters; irow++) { for (msize_type jcol = 0; jcol < nsamples; jcol++) { if (avail(irow, jcol) == result(irow, ucount-1)) { avail(irow, jcol) = avail(irow, ucount-1); } } } } /* * once all but the last points of result are filled in, there is only * one choice left */ for (msize_type irow = 0; irow < nparameters; irow++) { result(irow, 0u) = avail(irow, 0u); } result.transpose(); //#ifdef _DEBUG bool test = isValidLHS(result); if (!test) { /* the error function should send an error message through R */ throw std::runtime_error("Invalid Hypercube\n"); // LCOV_EXCL_LINE } //#endif #if PRINT_RESULT lhsPrint(result, 0); #endif } } // end namespace lhs/src/xtndeclare.h0000644000176200001440000001005513425401602014127 0ustar liggesusers/* * NOTE: This file should be excluded from the Doxygen build * * file xtndeclare.h * author Robert Carnell * copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ /* This code was computer generated */ /// @cond std::vector xtn2t2; std::vector xtn2t3; std::vector xtn2t4; std::vector xtn2t5; std::vector xtn2t6; std::vector xtn2t7; std::vector xtn2t8; std::vector xtn2t9; std::vector xtn2t10; std::vector xtn2t11; std::vector xtn2t12; std::vector xtn2t13; std::vector xtn2t14; std::vector xtn2t15; std::vector xtn2t16; std::vector xtn2t17; std::vector xtn2t18; std::vector xtn2t19; std::vector xtn2t20; std::vector xtn2t21; std::vector xtn2t22; std::vector xtn2t23; std::vector xtn2t24; std::vector xtn2t25; std::vector xtn2t26; std::vector xtn2t27; std::vector xtn2t28; std::vector xtn2t29; std::vector xtn3t2; std::vector xtn3t3; std::vector xtn3t4; std::vector xtn3t5; std::vector xtn3t6; std::vector xtn3t7; std::vector xtn3t8; std::vector xtn3t9; std::vector xtn3t10; std::vector xtn3t11; std::vector xtn3t12; std::vector xtn3t13; std::vector xtn3t14; std::vector xtn3t15; std::vector xtn3t16; std::vector xtn3t17; std::vector xtn3t18; std::vector xtn5t2; std::vector xtn5t3; std::vector xtn5t4; std::vector xtn5t5; std::vector xtn5t6; std::vector xtn5t7; std::vector xtn5t8; std::vector xtn5t9; std::vector xtn5t10; std::vector xtn5t11; std::vector xtn5t12; std::vector xtn7t2; std::vector xtn7t3; std::vector xtn7t4; std::vector xtn7t5; std::vector xtn7t6; std::vector xtn7t7; std::vector xtn7t8; std::vector xtn7t9; std::vector xtn7t10; std::vector xtn11t2; std::vector xtn11t3; std::vector xtn11t4; std::vector xtn11t5; std::vector xtn11t6; std::vector xtn11t7; std::vector xtn11t8; std::vector xtn13t2; std::vector xtn13t3; std::vector xtn13t4; std::vector xtn13t5; std::vector xtn13t6; std::vector xtn13t7; std::vector xtn13t8; std::vector xtn17t2; std::vector xtn17t3; std::vector xtn17t4; std::vector xtn17t5; std::vector xtn17t6; std::vector xtn17t7; std::vector xtn19t2; std::vector xtn19t3; std::vector xtn19t4; std::vector xtn19t5; std::vector xtn19t6; std::vector xtn19t7; std::vector xtn23t2; std::vector xtn23t3; std::vector xtn23t4; std::vector xtn23t5; std::vector xtn23t6; std::vector xtn29t2; std::vector xtn29t3; std::vector xtn29t4; std::vector xtn29t5; std::vector xtn29t6; std::vector xtn31t2; std::vector xtn31t3; std::vector xtn31t4; std::vector xtn31t5; std::vector xtn31t6; std::vector xtn37t2; std::vector xtn37t3; std::vector xtn37t4; std::vector xtn37t5; std::vector xtn41t2; std::vector xtn41t3; std::vector xtn41t4; std::vector xtn41t5; std::vector xtn43t2; std::vector xtn43t3; std::vector xtn43t4; std::vector xtn43t5; std::vector xtn47t2; std::vector xtn47t3; std::vector xtn47t4; std::vector xtn47t5; /// @endcond lhs/src/runif.h0000644000176200001440000000664413425401602013132 0ustar liggesusers/** * @file runif.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef RUNIF_H #define RUNIF_H #include "OACommonDefines.h" /** * Macro to define a seed is within range */ #define SEEDOK 1 /** * Macro to define a seed is not within range */ #define SEEDBAD 0 /** * Macro to set the length of the seed vector */ #define SEED_VECTOR_LENGTH (97+1) namespace oacpp { /** * A set of seed variables for the random number generator */ struct SeedSet { /** seed i */ int is; /** seed j */ int js; /** seed k */ int ks; /** seed l */ int ls; }; /** * Marsaglia - Zaman universal random number generator. * * reinitialization: call seed(is,js,ks,ls), with integer arguments * from 1 to 168, not all 1. * generate n uniform random numbers and store in x(n): call ranums(x,n). * * Transliterated from FORTRAN to C by Art Owen, 4 March 1993. */ class RUnif { public: /** Constructor */ RUnif(); /** Constructor with individual seeds */ RUnif(int is, int js, int ks, int ls); /** Constructor with a seed set */ RUnif(SeedSet seedSet); ~RUnif() {}; /** * sets seed integers, rejects invalid input * @param is seed * @param js seed * @param ks seed * @param ls seed */ void seed(int is, int js, int ks, int ls ); /** * Set the seeds to equal the numbers in the seedSet * @param seedSet a set of four seeds */ void seed(SeedSet seedSet); /** * Get the seed set * @return the SeedSet struct containing the seeds */ SeedSet getSeedSet(); /** * random uniform number generator * @param x a double vector to contain the random numbers * @param n the length of the vector */ void runif(std::vector & x, int n); /** * a mod b * @param a base * @param b modulus * @return an integer result */ static int mod(int a, int b); private: /** * is the seed ok? * @param is seed * @param js seed * @param ks seed * @param ls seed * @return 1 if seeds ok, 0 otherwise */ static int seedok(int is, int js, int ks, int ls ); /** * sets z[0] through z[n-1] to the next n random uniforms between 0 and 1 * @param x double vector * @param n length of the vector */ void ranums(std::vector & x, int n); int m_jent, m_i, m_j, m_k, m_l, ip, jp; double u[SEED_VECTOR_LENGTH]; double c, cd, cm; }; } #endif lhs/src/lhs_r.h0000644000176200001440000001052313425401602013105 0ustar liggesusers/** * @file lhs_r.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #ifndef LHS_R_H #define LHS_R_H #include #include "LHSCommonDefines.h" #include "lhs_r_utilities.h" #include "RStandardUniform.h" /** * Improved Latin hypercube sample algorithm * @param n (IntegerVector length 1) number of rows / samples in the lhs * @param k (IntegerVector length 1) number parameters / columns in the lhs * @param dup (IntegerVector length 1) A factor that determines the number of candidate points used in the search. * @return (NumericMatrix dim n x k) an lhs */ RcppExport SEXP improvedLHS_cpp(SEXP n, SEXP k, SEXP dup); /** * Latin hypercube sample algorithm using the maximin algorithm * @param n (IntegerVector length 1) number of rows / samples in the lhs * @param k (IntegerVector length 1) number parameters / columns in the lhs * @param dup (IntegerVector length 1) A factor that determines the number of candidate points used in the search. * @return (NumericMatrix dim n x k) an lhs */ RcppExport SEXP maximinLHS_cpp(SEXP n, SEXP k, SEXP dup); /** * Optimal Latin hypercube sample algorithm * @param n (IntegerVector length 1) number of rows / samples in the lhs * @param k (IntegerVector length 1) number parameters / columns in the lhs * @param maxsweeps (IntegerVector length 1) the maximum number of sweeps to use in the algorithm * @param eps (NumericVector length 1) The optimal stopping criterion * @param bVerbose (LogicalVector length 1) should messages be printed * @return (NumericMatrix dim n x k) an lhs */ RcppExport SEXP optimumLHS_cpp(SEXP n, SEXP k, SEXP maxsweeps, SEXP eps, SEXP bVerbose); /** * Optimum Latin hypercube sample with a seed sample * @param n (IntegerVector length 1) number of rows / samples in the lhs * @param k (IntegerVector length 1) number parameters / columns in the lhs * @param maxsweeps (IntegerVector length 1) the maximum number of sweeps to use in the algorithm * @param eps (NumericVector length 1) The optimal stopping criterion * @param pOld (NumericMatrix dim n x k) a seed matrix * @param bVerbose (LogicalVector length 1) should messages be printed? * @return (NumericMatrix dim n x k) an lhs */ RcppExport SEXP optSeededLHS_cpp(SEXP n, SEXP k, SEXP maxsweeps, SEXP eps, SEXP pOld, SEXP bVerbose); /** * a simple random Latin hypercube sample * @param n (IntegerVector length 1) number of rows / samples in the lhs * @param k (IntegerVector length 1) number parameters / columns in the lhs * @param preserveDraw (LogicalVector length 1) should be same draw be taken regardless of the number of parameters selected * @return (NumericMatrix dim n x k) an lhs */ RcppExport SEXP randomLHS_cpp(SEXP n, SEXP k, SEXP preserveDraw); /** * A Latin hypercube sample using a genetic algorithm * @param n (IntegerVector length 1) number of rows / samples in the lhs * @param k (IntegerVector length 1) number parameters / columns in the lhs * @param pop (IntegerVector length 1) the number of designs in the initial population * @param gen (IntegerVector length 1) the number of generations over which the algorithm is applied * @param pMut (NumericVector length 1) The probability with which a mutation occurs in a column of the progeny * @param criterium (NumericVector length 1) The optimality criterium of the algorithm. Default is S. Maximin is also supported * @param bVerbose (LogicalVector length 1) Print informational messages * @return (NumericMatrix dim n x k) an lhs */ RcppExport SEXP geneticLHS_cpp(SEXP n, SEXP k, SEXP pop, SEXP gen, SEXP pMut, SEXP criterium, SEXP bVerbose); #endif /* LHS_R_H */ lhs/src/oalhs_r.h0000644000176200001440000000407413425401602013431 0ustar liggesusers/** * @file oalhs_r.h * @author Robert Carnell * @copyright Copyright (c) 2019, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #ifndef OALHS_R_H #define OALHS_R_H #include #include "oa_r_utils.h" #include "oaLHS.h" #include "RStandardUniform.h" /** * Create a Latin hypercube sample from an orthogonal array * * @param n the number of rows in the LHS * @param k the number of parameters or columns in the LHS * @param oa the orthogonal array to be used as the basis for the LHS * @param bverbose should information be printed d * @return a numeric (double) matrix */ RcppExport SEXP /*double matrix*/ oa_to_lhs(SEXP /*int*/ n, SEXP /*int*/ k, SEXP /*int matrix*/ oa, SEXP /*bool*/ bverbose); /** * Create an Orthogonal Array Latin hypercube sample * * @param n the number of rows in the LHS * @param k the number of parameters or columns in the LHS * @param bChooseLargerDesign should a larger design than the one requested be created to match the oa generator * @param bverbose should information be printed d * @return a numeric (double) matrix */ RcppExport SEXP /*double matrix*/ create_oalhs(SEXP /*int*/ n, SEXP /*int*/ k, SEXP /*bool*/ bChooseLargerDesign, SEXP /*bool*/ bverbose); #endif /* OALHS_R_H */ lhs/src/improvedLHS.cpp0000644000176200001440000002147613425401602014536 0ustar liggesusers/** * @file improvedLHS.cpp * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #include "LHSCommonDefines.h" #include "utilityLHS.h" /* * Arrays are passed into this routine to allow R to allocate and deallocate * memory within the wrapper function. * The R internal random numer generator is used so that R can set.seed for * testing the functions. * This code uses ISO C90 comment styles and layout * Dimensions: result K x N * avail K x N * point1 K x DUP(N-1) * list1 DUP(N-1) * vec K * Parameters: * N: The number of points to be sampled * K: The number of dimensions (or variables) needed * dup: The duplication factor which affects the number of points * that the optimization algorithm has to choose from * References: Please see the package documentation * */ namespace lhslib { void improvedLHS(int n, int k, int dup, bclib::matrix & result, bclib::CRandom & oRandom) { if (n < 1 || k < 1 || dup < 1) { throw std::runtime_error("number of samples (n), number of parameters (k), and duplication must be positive"); } msize_type nsamples = static_cast(n); msize_type nparameters = static_cast(k); msize_type duplication = static_cast(dup); if (nsamples != result.rowsize() || nparameters != result.colsize()) { throw std::runtime_error("result should be n x k for the lhslib::improvedLHS call"); } // now transpose the matrix for future calls result.transpose(); // now it is k x n // ********** matrix_unsafe m_result = matrix_unsafe(nparameters, nsamples, result); /* the length of the point1 columns and the list1 vector */ msize_type len = duplication * (nsamples - 1); /* create memory space for computations */ bclib::matrix avail = bclib::matrix(nparameters, nsamples); bclib::matrix point1 = bclib::matrix(nparameters, len); std::vector list1 = std::vector(len); std::vector vec = std::vector(nparameters); /* optimum spacing between points */ double opt = static_cast(nsamples) / ( std::pow(static_cast(nsamples), (1.0 / static_cast(nparameters)))); /* the square of the optimum spacing between points */ double opt2 = opt * opt; /* index of the current candidate point */ vsize_type point_index; /* index of the optimum point */ unsigned int best; /* the squared distance between points */ unsigned int distSquared; /* * the minimum difference between the squared distance and the squared * optimum distance */ double min_all; /* The minumum candidate squared distance between points */ unsigned int min_candidate; /* initialize the avail matrix */ initializeAvailableMatrix(avail); /* * come up with an array of K integers from 1 to N randomly * and put them in the last column of result */ for (msize_type irow = 0; irow < nparameters; irow++) { result(irow, nsamples-1) = static_cast(std::floor(oRandom.getNextRandom() * static_cast(nsamples) + 1.0)); } /* * use the random integers from the last column of result to place an N value * randomly through the avail matrix */ for (msize_type irow = 0; irow < nparameters; irow++) { avail(irow, static_cast(result(irow, nsamples-1) - 1)) = static_cast(nsamples); } /* move backwards through the result matrix columns.*/ for (msize_type ucount = nsamples - 1; ucount > 0; ucount--) { //unsigned int ucount = static_cast(count); for (msize_type irow = 0; irow < nparameters; irow++) { for (msize_type jcol = 0; jcol < duplication; jcol++) { /* create the list1 vector */ for (vsize_type j = 0; j < ucount; j++) { list1[j + ucount*jcol] = avail(irow, j); } } /* create a set of points to choose from. Note, need to use int*/ /* Note: can't do col = count*duplication - 1; col >= 0 because it throws a warning at W4 */ for (msize_type ujcol = ucount * duplication; ujcol > 0; ujcol--) { //unsigned int ujcol = static_cast(jcol); point_index = static_cast(std::floor(oRandom.getNextRandom() * static_cast(ujcol))); point1(irow, ujcol-1) = list1[point_index]; list1[point_index] = list1[ujcol-1]; } } min_all = DBL_MAX; best = 0; for (msize_type jcol = 0; jcol < duplication * ucount - 1; jcol++) { min_candidate = UINT_MAX; for (msize_type j = ucount; j < nsamples; j++) { distSquared = 0; /* * find the distance between candidate points and the points already * in the sample */ for (msize_type kindex = 0; kindex < nparameters; kindex++) { vec[kindex] = point1(kindex, jcol) - result(kindex, j); distSquared += vec[kindex] * vec[kindex]; } /* original code compared dist1 to opt, but using the square root * function and recasting distSquared to a double was unnecessary. * dist1 = sqrt((double) distSquared); * if (min_candidate > dist1) min_candidate = dist1; */ /* * if the distSquard value is the smallest so far place it in * min candidate */ if (min_candidate > distSquared) { min_candidate = distSquared; } } /* * if the difference between min candidate and opt2 is the smallest so * far, then keep that point as the best. */ if (std::fabs(static_cast(min_candidate) - opt2) < min_all) { min_all = std::fabs(static_cast(min_candidate) - opt2); best = static_cast(jcol); } } /* take the best point out of point1 and place it in the result */ for (msize_type irow = 0; irow < nparameters; irow++) { result(irow, ucount - 1) = point1(irow, best); } /* update the numbers that are available for the future points */ for (msize_type irow = 0; irow < nparameters; irow++) { for (msize_type jcol = 0; jcol < nsamples; jcol++) { if (avail(irow, jcol) == result(irow, ucount - 1)) { avail(irow, jcol) = avail(irow, ucount-1); } } } } /* * once all but the last points of result are filled in, there is only * one choice left */ for (msize_type jrow = 0; jrow < nparameters; jrow++) { result(jrow, 0u) = avail(jrow, 0u); } result.transpose(); //#if _DEBUG bool test = isValidLHS(result); if (!test) { throw std::runtime_error("Invalid Hypercube\n"); // LCOV_EXCL_LINE } //#endif #if PRINT_RESULT lhsPrint(result, 0); #endif } } // end namespace lhs/src/LHSCommonDefines.h0000644000176200001440000001344113425401602015075 0ustar liggesusers/** * @file LHSCommonDefines.h * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #ifndef LHSCOMMONDEFINES_H #define LHSCOMMONDEFINES_H #include #include #include #include #include #include #include #include #include #include #include #include "matrix.h" #include "order.h" #include "CRandom.h" #ifdef RCOMPILE #include #define PRINT_MACRO Rcpp::Rcout #define ERROR_MACRO Rcpp::Rcerr #else // RCOMPILE /** Macro to choose the function for printing */ #define PRINT_MACRO std::cout /** Macro to choose the function for error printing */ #define ERROR_MACRO std::cerr #endif // RCOMPILE /** Should results be printed */ #define PRINT_RESULT 0 /** * @namespace lhslib LHS c++ Library namespace */ namespace lhslib { /** * Improved Latin hypercube sample algorithm * @param n number of rows / samples in the lha * @param k number parameters / columns in the lhs * @param dup A factor that determines the number of candidate points used in the search. * @param result the result matrix * @param oRandom the random number stream */ void improvedLHS(int n, int k, int dup, bclib::matrix & result, bclib::CRandom & oRandom); /** * Latin hypercube sample algorithm with maximin criterion * @param n number of rows / samples in the lha * @param k number parameters / columns in the lhs * @param dup A factor that determines the number of candidate points used in the search. * @param result the result matrix * @param oRandom the random number stream */ void maximinLHS(int n, int k, int dup, bclib::matrix & result, bclib::CRandom & oRandom); /** * Optimum Latin hypercube sample algorithm * @param n number of rows / samples in the lha * @param k number parameters / columns in the lhs * @param maxSweeps the maximum number of sweeps to use in the algorithm * @param eps The optimal stopping criterion * @param outlhs the resultant lhs * @param optimalityRecordLength the length of a vector used in the calculations * @param oRandom the random number stream * @param bVerbose should messages be printed? */ void optimumLHS(int n, int k, int maxSweeps, double eps, bclib::matrix & outlhs, int optimalityRecordLength, bclib::CRandom & oRandom, bool bVerbose); /** * Application of the optimum lhs method to a seeded Latin hypercube * @param n number of rows / samples in the lhs * @param k number parameters / columns in the lhs * @param maxSweeps the maximum number of sweeps to use in the algorithm * @param eps The optimal stopping criterion * @param pOld the seeded lhs * @param JLen the length of a vector used in the calculations * @param bVerbose should messages be printed? */ void optSeededLHS(int n, int k, int maxSweeps, double eps, bclib::matrix & pOld, int JLen, bool bVerbose); /** * type of size type for use with bclib::matrix * @note the type of the matrix (i.e. int) is irrelevant for size_type */ typedef bclib::matrix::size_type msize_type; /** * type of size type for use with std::vector * @note the type of the vector (i.e. int) is irrelevant for size_type */ typedef std::vector::size_type vsize_type; /** * Create a random latin hypercube sample * @param n number of rows / samples in the lhs * @param k number parameters / columns in the lhs * @param bPreserveDraw should the order of the draw be preserved if less columns are selected * @param result the lhs * @param oRandom the random number stream */ void randomLHS(int n, int k, bool bPreserveDraw, bclib::matrix & result, bclib::CRandom & oRandom); /** * Create a random latin hypercube sample with integer values * @param n number of rows / samples in the lhs * @param k number parameters / columns in the lhs * @param result the lhs * @param oRandom the random number stream */ void randomLHS(int n, int k, bclib::matrix & result, bclib::CRandom & oRandom); /** * Create a latin hypercube sample optimized by some criteria with a genetic algorithm * @param n number of rows / samples in the lhs * @param k number parameters / columns in the lhs * @param pop the population of the genetic algorithm in each iteration * @param gen the number of generations to use * @param pMut the mutation rate * @param criterium the optimization criterium * @param bVerbose should messages be printed? * @param result the lhs * @param oRandom the random number stream */ void geneticLHS(int n, int k, int pop, int gen, double pMut, std::string criterium, bool bVerbose, bclib::matrix & result, bclib::CRandom & oRandom); } #endif /* LHSCOMMONDEFINES_H */ lhs/src/oaLHS.h0000644000176200001440000000672113425401602012751 0ustar liggesusers/* * @file oaLHS.h * @author Robert Carnell * @copyright Copyright (c) 2019, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #ifndef OALHS_H #define OALHS_H #include "OACommonDefines.h" #include "matrix.h" #include "CRandom.h" #include "primes.h" #include "order.h" #include "oaLHSUtility.h" #include "COrthogonalArray.h" namespace oalhslib { /** * create an orthogonal array latin hypercube from an orthogonal array * @param n the number of rows or samples * @param k the number of columns or parameters * @param oa an orthogonal array * @param intlhs an integer based Latin hypercube sample * @param lhs a Latin hypercube sample * @param bVerbose will messages be printed * @param oRandom a random generator */ void oaLHS(int n, int k, const bclib::matrix & oa, bclib::matrix & intlhs, bclib::matrix & lhs, bool bVerbose, bclib::CRandom & oRandom); /** * create a deterministic orthogonal array latin hypercube from an orthogonal array * @param n the number of rows or samples * @param k the number of columns or parameters * @param oa an orthogonal array * @param intlhs an integer based Latin hypercube sample * @param bVerbose will messages be printed */ void oaLHS(int n, int k, const bclib::matrix & oa, bclib::matrix & intlhs, bool bVerbose); /** * print an orthogonal array and the unique levels * @param oa an orthogonal array * @param uniqueLevelsVector */ void printOAandUnique(const bclib::matrix & oa, const std::vector > & uniqueLevelsVector); /** * replace orthogonal array values * @param oa an orthogonal array * @param uniqueLevelsVector * @param intlhs an integer based Latin hypercube sample * @param oRandom a random number generator * @param isRandom is the result randomized */ void replaceOAValues(const bclib::matrix & oa, const std::vector > & uniqueLevelsVector, bclib::matrix & intlhs, bclib::CRandom & oRandom, bool isRandom); /** * generate an orthogonal array Latin hypercube * @param n the number of rows or samples * @param k the number of columns or parameters * @param oalhs the generated Latin hypercube sample * @param bChooseLargerDesign choose a larger design if the orthogonal array is not sufficient * @param bVerbose should messages be printed * @param oRandom a random generator */ void generateOALHS(int n, int k, bclib::matrix & oalhs, bool bChooseLargerDesign, bool bVerbose, bclib::CRandom & oRandom); } #endif /* OALHS_H */ lhs/src/oa_r.cpp0000644000176200001440000001313613425401602013254 0ustar liggesusers/** * @file oa_r.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #include "oa_r.h" RcppExport SEXP /*int matrix*/ oa_type1(SEXP /*char*/ type, SEXP /*int*/ q, SEXP /*int*/ ncol, SEXP /*bool*/ bRandom) { BEGIN_RCPP Rcpp::IntegerMatrix rcppA(1,1); // need to initialize oacpp::COrthogonalArray oa; if (TYPEOF(q) != INTSXP || TYPEOF(ncol) != INTSXP) { Rcpp_error("q, ncol, and n should be integers"); } if (TYPEOF(type) != STRSXP || TYPEOF(bRandom) != LGLSXP) { Rcpp_error("type should be a character and bRandom should be a logical"); } Rcpp::IntegerVector ivq(q); Rcpp::IntegerVector ivncol(ncol); Rcpp::LogicalVector lvbRandom(bRandom); if (ivq.size() > 1 || ivncol.size() > 1 || lvbRandom.size() > 1) { Rcpp_error("q, ncol, and bRandom can only be of length 1"); } int qlocal = Rcpp::as(q); int ncollocal = Rcpp::as(ncol); int nlocal = 0; std::string stype = Rcpp::as(type); bool bRandomLocal = Rcpp::as(bRandom); if (qlocal == NA_INTEGER || ncollocal == NA_INTEGER || bRandomLocal == NA_LOGICAL) { Rcpp_error("q, ncol, and bRandom are not permitted to be NA"); } if (stype == typeConstants::BOSE) { oa.bose(qlocal, ncollocal, &nlocal); } else if (stype == typeConstants::BOSEBUSH) { oa.bosebush(qlocal, ncollocal, &nlocal); } else if (stype == typeConstants::BUSH) { oa.bush(qlocal, ncollocal, &nlocal); } else if (stype == typeConstants::ADDELKEMP3) { oa.addelkemp3(qlocal, ncollocal, &nlocal); } else if (stype == typeConstants::ADDELKEMP) { oa.addelkemp(qlocal, ncollocal, &nlocal); } else { std::stringstream sstype; sstype << stype << " is an Unrecognized orthogonal array algorithm"; const std::string ssstype = sstype.str(); Rcpp_error(ssstype.c_str()); } oarutils::convertToIntegerMatrix(oa.getoa(), rcppA); if (bRandomLocal) { oarutils::randomizeOA(rcppA, qlocal); } return rcppA; END_RCPP } RcppExport SEXP /*int matrix*/ oa_type2(SEXP /*char*/ type, SEXP /*int*/ int1, SEXP /*int*/ q, SEXP /*int*/ ncol, SEXP /*bool*/ bRandom) { BEGIN_RCPP Rcpp::IntegerMatrix rcppA(1,1); // need to initialize oacpp::COrthogonalArray oa; if (TYPEOF(q) != INTSXP || TYPEOF(ncol) != INTSXP || TYPEOF(int1) != INTSXP) { Rcpp_error("q, int1, and ncol should be integers"); } if (TYPEOF(type) != STRSXP || TYPEOF(bRandom) != LGLSXP) { Rcpp_error("type should be a character and bRandom should be a logical"); } Rcpp::IntegerVector ivint1(int1); Rcpp::IntegerVector ivq(q); Rcpp::IntegerVector ivncol(ncol); Rcpp::LogicalVector lvbRandom(bRandom); Rcpp::CharacterVector cvtype(type); if (ivq.size() > 1 || ivncol.size() > 1 || lvbRandom.size() > 1 || ivint1.size() > 1 || cvtype.size() > 1) { ::Rf_error("q, ncol, type, and bRandom can only be of length 1"); } int qlocal = Rcpp::as(q); int ncollocal = Rcpp::as(ncol); int nlocal = 0; int int1local = Rcpp::as(int1); bool bRandomLocal = Rcpp::as(bRandom); if (qlocal == NA_INTEGER || ncollocal == NA_INTEGER || int1local == NA_INTEGER || bRandomLocal == NA_LOGICAL) { if (cvtype[0] == typeConstants::BOSEBUSHL) { Rcpp_error("q, lambda, and bRandom are not permitted to be NA"); } else if (cvtype[0] == typeConstants::BUSHT) { Rcpp_error("q, str, and bRandom are not permitted to be NA"); } else if (cvtype[0] == typeConstants::ADDELKEMPN) { Rcpp_error("q, akn, and bRandom are not permitted to be NA"); } else { std::stringstream sstype; sstype << cvtype[0] << " is an Unrecognized orthogonal array algorithm"; const std::string ssstype = sstype.str(); Rcpp_error(ssstype.c_str()); } } if (cvtype[0] == typeConstants::BOSEBUSHL) { // int1 is lambda oa.bosebushl(int1local, qlocal, ncollocal, &nlocal); } else if (cvtype[0] == typeConstants::BUSHT) { // int1 is str oa.busht(int1local, qlocal, ncollocal, &nlocal); } else if (cvtype[0] == typeConstants::ADDELKEMPN) { // int1 is akn oa.addelkempn(int1local, qlocal, ncollocal, &nlocal); } else { std::stringstream sstype; sstype << cvtype[0] << " is an Unrecognized orthogonal array algorithm"; const std::string ssstype = sstype.str(); Rcpp_error(ssstype.c_str()); } oarutils::convertToIntegerMatrix(oa.getoa(), rcppA); if (bRandomLocal) { oarutils::randomizeOA(rcppA, qlocal); } return rcppA; END_RCPP } lhs/src/CRandom.h0000644000176200001440000000622013425401602013320 0ustar liggesusers/** * @file CRandom.h * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ /*** from sunif.c ****/ /* * Mathlib : A C Library of Special Functions * Copyright (C) 2000, 2003 The R Core Team * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * http://www.r-project.org/Licenses/ * */ #ifndef CRANDOM_H #define CRANDOM_H namespace bclib { /** * Pseudorandom number abstract class * @tparam the type that the random number generator will generate */ template class CRandom { public: /** * get the next random value from * @return the random value */ virtual T getNextRandom() = 0; }; /** * random numbers from a standard uniform distribution */ class CRandomStandardUniform : public CRandom { public: /** * default constructor */ CRandomStandardUniform(){m_i1 = 1234; m_i2 = 5678;}; /** * get the next random number from the stream * @return random deviate */ double getNextRandom() { m_i1 = 36969*(m_i1 & 0177777) + (m_i1>>16); m_i2= 18000*(m_i2 & 0177777) + (m_i2>>16); return ((m_i1 << 16)^(m_i2 & 0177777)) * 2.328306437080797e-10; /* in [0,1) */ }; /** * set the random seed * @param i1 seed1 * @param i2 seed2 */ void setSeed(unsigned int i1, unsigned int i2) { m_i1 = i1; m_i2 = i2; } /** * get the random seeds * @param i1 pointer to seed1 * @param i2 pointer to seed2 */ void getSeed(unsigned int *i1, unsigned int *i2) { *i1 = m_i1; *i2 = m_i2; } private: unsigned int m_i1; unsigned int m_i2; }; } #endif /* CRANDOM_H */ lhs/src/lhs_r_utilities.h0000644000176200001440000001243013425401602015177 0ustar liggesusers/** * @file lhs_r_utilities.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #ifndef LHS_R_UTILITIES_H #define LHS_R_UTILITIES_H #include #include "LHSCommonDefines.h" /** * @namespace lhs_r a namespace for the lhs methods used in the R interface */ namespace lhs_r { /** * find the order of an input vector using 0 as the first order * @param v the input values * @param order the order of the input values */ void findorder_zero(const Rcpp::NumericVector & v, Rcpp::IntegerVector & order); /** * convert an integer matrix to a numeric latin hypercube sample * @param intMat the input matrix to be converted * @return a latin hypercube sample */ Rcpp::NumericMatrix convertIntegerToNumericLhs(const bclib::matrix & intMat); /** * convert a numeric matrix to a numeric latin hypercube sample * @param intMat the input matrix to be converted * @return a Latin hypercube sample */ Rcpp::NumericMatrix convertMatrixToNumericLhs(const bclib::matrix & intMat); /** * convert a Rcpp::IntegerMatrix to a numeric latin hypercube sample * @param intMat the input matrix to be converted * @return a Latin hypercube sample */ Rcpp::NumericMatrix convertIntegerToNumericLhs(const Rcpp::IntegerMatrix & intMat); /** * a uniform integer sample between min and max * @param n the size of the sample * @param min_int the minimum integer in the sample * @param max_int the maximum integer in the sample * @return an integer vector */ Rcpp::IntegerVector runifint(unsigned int n, int min_int, int max_int); /** * check the arguments are valid * @param n number of rows / samples in the lhs * @param k number parameters / columns in the lhs */ void checkArguments(int n, int k); /** * check that the arguments are valid * @param n number of rows / samples in the lhs * @param k number parameters / columns in the lhs * @param dup A factor that determines the number of candidate points used in the search. */ void checkArguments(int n, int k, int dup); /** * check that the arguments are valid * @param n number of rows / samples in the lhs * @param k number parameters / columns in the lhs * @param maxsweeps the maximum number of sweeps to use in the algorithm * @param eps The optimal stopping criterion */ void checkArguments(int n, int k, int maxsweeps, double eps); /** * develop an lhs sample in the degenerate case * @param k number parameters / columns in the lhs * @param oRandom a random number generator for the hypercube * @return the numeric matrix for the degenerate case */ Rcpp::NumericMatrix degenerateCase(int k, bclib::CRandom & oRandom); /** * Calculate the distance between points in a matrix * @param mat the matrix to use for the calculation * @tparam RTYPE the type of SEXP * @return the matrix of distances */ template Rcpp::NumericMatrix calculateDistance(Rcpp::Matrix & mat) // non-const because of the matrix row { Rcpp::NumericMatrix result(mat.rows(), mat.cols()); for (int i = 0; i < mat.rows() - 1; i++) { for (int j = i+1; j < mat.rows(); j++) { typename Rcpp::Matrix::Row rowi = mat.row(i); typename Rcpp::Matrix::Row rowj = mat.row(j); double sum = static_cast(Rcpp::sum((rowi - rowj) * (rowi - rowj))); result(i,j) = sqrt(sum); } } return result; } /** * calculate the S optimal criterion * @param mat the input matrix * @tparam RTYPE the type of SEXP * @return the S optimality criterion */ template double calculateSOptimal(Rcpp::Matrix & mat) { // B[i] <- 1/sum(1/dist(A[, , i])) Rcpp::NumericMatrix dist = lhs_r::calculateDistance(mat); Rcpp::NumericMatrix::iterator i; for (i = dist.begin(); i != dist.end(); ++i) { if (*i != 0.0) { *i = 1.0 / *i; } } double sum = std::accumulate(dist.begin(), dist.end(), 0.0); if (sum > 0) { return 1.0 / sum; } else { throw std::runtime_error("problem with calculateSOptimal"); } } } #endif /* LHS_R_UTILITIES_H */ lhs/src/ak.h0000644000176200001440000000646613425401602012404 0ustar liggesusers/** * @file ak.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef AK_H #define AK_H #include "OACommonDefines.h" #include "galois.h" #include "primes.h" #include "matrix.h" namespace oacpp { /** * Addelkemp class */ namespace oaaddelkemp { /** * Check that the parameters of the addelkemp3 algorithm are consistent * * @todo define p * * @param q the number of symbols * @param p * @param ncol the number of columns * @return an indicator of success */ int addelkemp3check(int q, int p, int ncol); /** * Addelkemp algorithm for even p * * @todo define b, c, and k * @param gf galois field object * @param kay the number of columns * @param b * @param c * @param k * @return an indicator of success */ int akeven(GF & gf, int* kay, std::vector & b, std::vector & c, std::vector & k ); /** * Addelkemp algorithm for odd p * * @todo define b, c, and k * @param gf galois field object * @param kay the number of columns * @param b * @param c * @param k * @return an indicator of success */ int akodd(GF & gf, int* kay, std::vector & b, std::vector & c, std::vector & k ); /** * Check that the parameters are consistent for the addelkempn algorithm * * @todo define p and akn * * @param q the number of symbols * @param p * @param akn * @param ncol the number of columns * @return an indicator of success */ int addelkempncheck(int q, int p, int akn, int ncol ); /** * The addelkemp algorithm for general n * * @todo define akn * * @param gf galois filed * @param akn * @param A the orthogonal array * @param ncol the number of columns * @return an indicator of success */ int addelkempn(GF & gf, int akn, bclib::matrix & A, int ncol ); /** * The addelkemp algorithm for n=3 * * @param gf galois field * @param A the orthogonal array * @param ncol the number of columns * @return an indicator of success */ int addelkemp3(GF & gf, bclib::matrix & A, int ncol ); } } #endif lhs/src/oaLHS.cpp0000644000176200001440000003557313425401602013313 0ustar liggesusers/** * @file oaLHS.cpp * @author Robert Carnell * @copyright Copyright (c) 2019, Robert Carnell * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . * */ #include "oaLHS.h" namespace oalhslib { typedef bclib::matrix::size_type msize_type; typedef bclib::matrix::columnwise_iterator columnit; typedef std::vector::iterator viterator; typedef std::vector::const_iterator vconstiterator; typedef std::vector::size_type vsize_type; // oa is provided in an arbitrary way (not necessarily all columns with the same q) void oaLHS(int n, int k, const bclib::matrix & oa, bclib::matrix & intlhs, bclib::matrix & lhs, bool bVerbose, bclib::CRandom & oRandom) { if (oa.rowsize() != static_cast(n) || oa.colsize() != static_cast(k)) { throw std::runtime_error("the size of the orthogonal array does not match the n and k parameters"); } if (intlhs.rowsize() != oa.rowsize() || intlhs.colsize() != oa.colsize()) { intlhs = bclib::matrix(oa.rowsize(), oa.colsize()); } if (lhs.rowsize() != oa.rowsize() || lhs.colsize() != oa.colsize()) { lhs = bclib::matrix(oa.rowsize(), oa.colsize()); } // iterate over the columns and make a list of the unique elements in the column std::vector > uniqueLevelsVector = std::vector >(oa.colsize()); oalhslib::findUniqueColumnElements(oa, uniqueLevelsVector); if (bVerbose) { printOAandUnique(oa, uniqueLevelsVector); // LCOV_EXCL_LINE } replaceOAValues(oa, uniqueLevelsVector, intlhs, oRandom, true); if (bVerbose) { PRINT_OUTPUT << "\ninteger lhs:\n" << intlhs.toString() << "\n"; // LCOV_EXCL_LINE } // transform integer hypercube to a double hypercube for (msize_type jcol = 0; jcol < static_cast(k); jcol++) { for (msize_type irow = 0; irow < static_cast(n); irow++) { lhs(irow, jcol) = static_cast(intlhs(irow, jcol)) - 1.0; } } int veclen = n * k; std::vector randomunif = std::vector(veclen); for (vsize_type i = 0; i < static_cast(veclen); i++) { randomunif[i] = oRandom.getNextRandom(); } bclib::matrix randomMatrix(n, k, randomunif); for (msize_type jcol = 0; jcol < static_cast(k); jcol++) { for (msize_type irow = 0; irow < static_cast(n); irow++) { lhs(irow,jcol) += randomMatrix(irow, jcol); lhs(irow,jcol) /= static_cast(n); } } } void printOAandUnique(const bclib::matrix & oa, const std::vector > & uniqueLevelsVector) // LCOV_EXCL_START { PRINT_OUTPUT << "\ninitial oa:\n" << oa.toString() << "\n"; PRINT_OUTPUT << "unique values per row:\n"; for (vsize_type vi = 0; vi < uniqueLevelsVector.size(); vi++) { for (vsize_type vvi = 0; vvi < uniqueLevelsVector[vi].size(); vvi++) { PRINT_OUTPUT << uniqueLevelsVector[vi][vvi] << ","; } PRINT_OUTPUT << "\n"; } } // LCOV_EXCL_STOP void oaLHS(int n, int k, const bclib::matrix & oa, bclib::matrix & intlhs, bool bVerbose) { if (oa.rowsize() != static_cast(n) || oa.colsize() != static_cast(k)) { throw std::runtime_error("wrong size"); } if (intlhs.rowsize() != oa.rowsize() || intlhs.colsize() != oa.colsize()) { intlhs = bclib::matrix(oa.rowsize(), oa.colsize()); } // iterate over the columns and make a list of the unique elements in the column std::vector > uniqueLevelsVector = std::vector >(oa.colsize()); oalhslib::findUniqueColumnElements(oa, uniqueLevelsVector); if (bVerbose) { printOAandUnique(oa, uniqueLevelsVector); // LCOV_EXCL_LINE } bclib::CRandomStandardUniform oRandom; replaceOAValues(oa, uniqueLevelsVector, intlhs, oRandom, false); if (bVerbose) { PRINT_OUTPUT << "\nintlhs:\n" << intlhs.toString() << "\n"; // LCOV_EXCL_LINE } } void replaceOAValues(const bclib::matrix & oa, const std::vector > & uniqueLevelsVector, bclib::matrix & intlhs, bclib::CRandom & oRandom, bool isRandom) { int basecount = 1; std::vector randints; std::vector randdouble; viterator tempit; for (msize_type i = 0; i < oa.colsize(); i++) { // reset the basecount for each column basecount = 1; for (vconstiterator vit = uniqueLevelsVector[i].begin(); vit != uniqueLevelsVector[i].end(); ++vit) { // count the number of times this value is in the oa column int tempcount = (int) std::count(oa.columnwisebegin(i), oa.columnwiseend(i), *vit); randints = std::vector(tempcount); if (isRandom) { randdouble = std::vector(tempcount); // get a random ordering for the digits for (std::vector::iterator itt = randdouble.begin(); itt != randdouble.end(); itt++) { *itt = oRandom.getNextRandom(); } //lhslib::runif_std(tempcount, randdouble, oRandom); bclib::findorder_zero(randdouble, randints); } else { for (int count = 0; count < tempcount; count++) { randints[count] = count; } } // replace the elements of intlhs corresponding to the current unique value viterator randintsit = randints.begin(); for (msize_type irow = 0; irow < oa.rowsize(); irow++) { if (oa(irow, i) == *vit && randintsit != randints.end()) { intlhs(irow, i) = basecount + *randintsit; ++randintsit; } } basecount += tempcount; } } } void generateOALHS(int n, int k, bclib::matrix & oalhs, bool bChooseLargerDesign, bool bVerbose, bclib::CRandom & oRandom) { if (bVerbose) { PRINT_OUTPUT << "\n"; // LCOV_EXCL_LINE } int q_addelkemp = bChooseLargerDesign ? (int) ceil(sqrt((double) n / 2.0)) : (int) floor(sqrt((double) n / 2.0)); while (oacpp::primes::isprimepow(q_addelkemp) == 0 && q_addelkemp >= 2) { if (bChooseLargerDesign) { q_addelkemp++; } else { q_addelkemp--; } } int n_addelkemp = 2*q_addelkemp*q_addelkemp; int k_addelkemp = k < 2*q_addelkemp + 1 ? k : 2*q_addelkemp + 1; if (bVerbose) { PRINT_OUTPUT << "Candidate OA: AddelKemp with q=" << q_addelkemp << " n=" << n_addelkemp << " k=" << k_addelkemp << "\n"; // LCOV_EXCL_LINE } int q_addelkemp3 = bChooseLargerDesign ? (int) ceil(pow((double) n / 2.0, 1.0/3.0)) : (int) floor(pow((double) n / 2.0, 1.0/3.0)); while (oacpp::primes::isprimepow(q_addelkemp3) == 0 && q_addelkemp3 >= 2) { if (bChooseLargerDesign) { q_addelkemp3++; } else { q_addelkemp3--; } } int n_addelkemp3 = 2*q_addelkemp3*q_addelkemp3*q_addelkemp3; int k_addelkemp3 = k < 2*q_addelkemp3*q_addelkemp3 + 2*q_addelkemp3 + 1 ? k : 2*q_addelkemp3*q_addelkemp3 + 2*q_addelkemp3 + 1; if (bVerbose) { PRINT_OUTPUT << "Candidate OA: AddelKemp3 with q=" << q_addelkemp3 << " n=" << n_addelkemp3 << " k=" << k_addelkemp3 << "\n"; // LCOV_EXCL_LINE } int q_bose = bChooseLargerDesign ? (int) ceil(sqrt((double) n)) : (int) floor(sqrt((double) n)); while (oacpp::primes::isprimepow(q_bose) == 0 && q_bose >= 2) { if (bChooseLargerDesign) { q_bose++; } else { q_bose--; } } int n_bose = q_bose*q_bose; int k_bose = k < q_bose + 1 ? k : q_bose + 1; if (bVerbose) { PRINT_OUTPUT << "Candidate OA: Bose with q=" << q_bose << " n=" << n_bose << " k=" << k_bose << "\n"; // LCOV_EXCL_LINE } int q_bosebush = bChooseLargerDesign ? (int) ceil(sqrt((double) n / 2.0)) : (int) floor(sqrt((double) n / 2.0)); if (q_bosebush % 2) { if (bChooseLargerDesign) { q_bosebush++; } else { q_bosebush--; } } int n_bosebush = 2*q_bosebush*q_bosebush; int k_bosebush = k < q_bosebush + 1 ? k : q_bosebush + 1; if (bVerbose) { PRINT_OUTPUT << "Candidate OA: BoseBush with q=" << q_bosebush << " n=" << n_bosebush << " k=" << k_bosebush << "\n"; // LCOV_EXCL_LINE } // Goal: Find the n and k that are the closest with atleast the required n and k std::vector types = std::vector(); std::vector ndiffs = std::vector(); std::vector ks = std::vector(); std::vector ns = std::vector(); types.push_back("addelkemp"); types.push_back("addelkemp3"); types.push_back("bose"); types.push_back("bosebush"); ks.push_back(k_addelkemp); ks.push_back(k_addelkemp3); ks.push_back(k_bose); ks.push_back(k_bosebush); ns.push_back(n_addelkemp); ns.push_back(n_addelkemp3); ns.push_back(n_bose); ns.push_back(n_bosebush); // if atleast one of the models has a greater n if (n_addelkemp >= n || n_addelkemp3 >= n || n_bose >= n || n_bosebush >= n) { ndiffs.push_back((n_addelkemp >= n) ? n_addelkemp - n : (n - n_addelkemp) * 100); ndiffs.push_back((n_addelkemp3 >= n) ? n_addelkemp3 - n : (n - n_addelkemp3) * 100); ndiffs.push_back((n_bose >= n) ? n_bose - n : (n - n_bose) * 100); ndiffs.push_back((n_bosebush >= n) ? n_bosebush - n : (n - n_bosebush) * 100); } else { ndiffs.push_back(static_cast(fabs(static_cast(n) - static_cast(n_addelkemp)))); ndiffs.push_back(static_cast(fabs(static_cast(n) - static_cast(n_addelkemp3)))); ndiffs.push_back(static_cast(fabs(static_cast(n) - static_cast(n_bose)))); ndiffs.push_back(static_cast(fabs(static_cast(n) - static_cast(n_bosebush)))); } // which is the smallest? std::vector norders = std::vector(ndiffs.size()); bclib::findorder_zero(ndiffs, norders); oacpp::COrthogonalArray coa = oacpp::COrthogonalArray(); std::string selected = ""; if (ks[norders[0]] >= k) { selected = types[norders[0]]; } else if (ks[norders[1]] >= k && ns[norders[1]] >= n) { selected = types[norders[1]]; } else if (ks[norders[2]] >= k && ns[norders[2]] >= n) { selected = types[norders[2]]; } else if (ks[norders[3]] >= k && ns[norders[3]] >= n) { selected = types[norders[3]]; } else { selected = types[norders[0]]; } if (selected == "addelkemp") { if (bVerbose) { PRINT_OUTPUT << "AddelKemp selected\n"; // LCOV_EXCL_LINE } coa.addelkemp(q_addelkemp, k_addelkemp, &n_addelkemp); } else if (selected == "addelkemp3") { if (bVerbose) { PRINT_OUTPUT << "AddelKemp3 selected\n"; // LCOV_EXCL_LINE } coa.addelkemp3(q_addelkemp3, k_addelkemp3, &n_addelkemp3); } else if (selected == "bose") { if (bVerbose) { PRINT_OUTPUT << "Bose selected\n"; // LCOV_EXCL_LINE } coa.bose(q_bose, k_bose, &n_bose); } else if (selected == "bosebush") { if (bVerbose) { PRINT_OUTPUT << "BoseBush selected\n"; // LCOV_EXCL_LINE } coa.bosebush(q_bosebush, k_bosebush, &n_bosebush); } bclib::matrix oa = coa.getoa(); bclib::matrix intoalhs = bclib::matrix(oa.rowsize(), oa.colsize()); oalhs = bclib::matrix(oa.rowsize(), oa.colsize()); // iterate over the columns and make a list of the unique elements in the column std::vector > uniqueLevelsVector = std::vector >(oa.colsize()); oalhslib::findUniqueColumnElements(oa, uniqueLevelsVector); if (bVerbose) { printOAandUnique(oa, uniqueLevelsVector); // LCOV_EXCL_LINE } replaceOAValues(oa, uniqueLevelsVector, intoalhs, oRandom, true); if (bVerbose) { PRINT_OUTPUT << "\ninteger lhs:\n" << intoalhs.toString() << "\n"; // LCOV_EXCL_LINE } // transform integer hypercube to a double hypercube for (msize_type jcol = 0; jcol < intoalhs.colsize(); jcol++) { for (msize_type irow = 0; irow < intoalhs.rowsize(); irow++) { oalhs(irow, jcol) = static_cast(intoalhs(irow, jcol)) - 1.0; } } size_t veclen = intoalhs.colsize() * intoalhs.rowsize(); std::vector randomunif = std::vector(veclen); for (vsize_type i = 0; i < veclen; i++) { randomunif[i] = oRandom.getNextRandom(); } bclib::matrix randomMatrix(intoalhs.rowsize(), intoalhs.colsize(), randomunif); for (msize_type jcol = 0; jcol < intoalhs.colsize(); jcol++) { for (msize_type irow = 0; irow < intoalhs.rowsize(); irow++) { oalhs(irow, jcol) += randomMatrix(irow, jcol); oalhs(irow, jcol) /= static_cast(intoalhs.rowsize()); } } } } lhs/src/galois.h0000644000176200001440000000572313425401602013262 0ustar liggesusers/** * @file galois.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef GALOIS_H #define GALOIS_H #include "OACommonDefines.h" #include "galdef.h" #include "primes.h" namespace oacpp { /** * Definitions for Galois Fields */ namespace galoisfield { /** * Multiplication in polynomial representation * * @param p modulus * @param n length of p1 and p2 * @param xton representation of x^n * @param p1 polynomial 1 * @param p2 polynomial 2 * @param prod the product of the polynomials */ void GF_poly_prod(int p, int n, std::vector & xton, std::vector p1, std::vector p2, std::vector & prod ); /** * Addition in polynomial representation * * @param p modulus * @param n the length of p1 and p2 * @param p1 polynomial 1 * @param p2 polynomial 2 * @param sum the sum of the polynomials */ void GF_poly_sum(int p, int n, std::vector p1, std::vector p2, std::vector & sum ); /** * Convert polynomial to integer in 0..q-1 * * @param p polynomial multiplier * @param n the length of poly * @param poly the polynomial * @return an integer */ int GF_poly2int( int p, int n, std::vector & poly ); /** * Print a Galois field * @param gf a Galois field struct */ void GF_print(GF & gf); /** * Prepare (+,*,^-1) lookup tables * * @param gf the Galois field * @param p the modulus * @param n the length of xton * @param xton the x^n vector * @return 1 for success */ int GF_ready(GF & gf, int p, int n, std::vector & xton ); /** * Get a Galois field with q arguments * @param q the number of arguments * @param gf the Galois field * @return 1 for success */ int GF_getfield(int q, GF & gf); /** * Set the Galois fields */ void GF_set_fields(); } } #endif lhs/src/runif.cpp0000644000176200001440000001172513425401602013461 0ustar liggesusers/** * @file runif.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "runif.h" namespace oacpp { RUnif::RUnif() { m_jent = m_i = m_j = m_k = m_l = ip = jp = 0; c = cd = cm = 0.0; RUnif::seed(1, 2, 3, 4); } RUnif::RUnif(int is, int js, int ks, int ls) { m_jent = m_i = m_j = m_k = m_l = ip = jp = 0; c = cd = cm = 0.0; RUnif::seed(is, js, ks, ls); } RUnif::RUnif(SeedSet seedSet) { m_jent = m_i = m_j = m_k = m_l = ip = jp = 0; c = cd = cm = 0.0; RUnif::seed(seedSet.is, seedSet.js, seedSet.ks, seedSet.ls); } void RUnif::seed(SeedSet seedSet) { RUnif::seed(seedSet.is, seedSet.js, seedSet.ks, seedSet.ls); } int RUnif::mod(int a, int b) { int ans; ans = a % b; if (ans >= 0) { return ans; } else { return ans + b; } } int RUnif::seedok(int is, int js, int ks, int ls) { if (is == 1 && js == 1 && ks == 1 && ls == 1) { return SEEDBAD; } if (is < 1 || js < 1 || ks < 1 || ls < 1) { return SEEDBAD; } if (is > 168 || js > 168 || ks > 168 || ls > 168) { return SEEDBAD; } return SEEDOK; } void RUnif::seed(int is, int js, int ks, int ls) { m_jent = 0; if (seedok(is, js, ks, ls) == SEEDOK) { m_i = is; m_j = js; m_k = ks; m_l = ls; } else { PRINT_OUTPUT << "Error: Invalid seed " << is << " " << js << " " << ks << " " << ls << "\n"; PRINT_OUTPUT << "Must be four integers between 1 and 168, and\n"; PRINT_OUTPUT << "must not all be 1. Seed not changed.\n"; } } SeedSet RUnif::getSeedSet() { SeedSet s; s.is = m_i; s.js = m_j; s.ks = m_k; s.ls = m_l; return s; } void RUnif::runif(std::vector & x, int n) { // if the seed is not ok, it was set by default and not through seed() if (!seedok(m_i, m_j, m_k, m_l)) { m_jent = 0; m_i = 12; m_j = 34; m_k = 56; m_l = 78; } ranums(x, n); } void RUnif::ranums(std::vector & x, int n) { int ii, jj, m; double s, t, uni; // if the seed is not ok, it was set by default and not through seed() if (!seedok(m_i, m_j, m_k, m_l)) { m_jent = 0; m_i = 12; m_j = 34; m_k = 56; m_l = 78; } if (m_jent != 0) { goto L30; } m_jent = 1; for (ii = 1; ii <= 97; ii++) { /* do 20 ii=1,97 */ s = 0.0; t = 0.5; for (jj = 1; jj <= 24; jj++) { /* do 10 jj=1,24 */ m = mod(mod(m_i*m_j, 179) * m_k, 179); m_i = m_j; m_j = m_k; m_k = m; m_l = mod(53 * m_l + 1, 169); if (mod(m_l * m, 64) >= 32) { s = s + t; } t = 0.5 * t; } /* 10 continue */ u[ii] = s; } /* 20 continue */ c = 362436.0 / 16777216.0; cd = 7654321.0 / 16777216.0; cm = 16777213.0 / 16777216.0; ip = 97; jp = 33; L30: for (ii = 1; ii <= n; ii++) { /* ii do 40 ii=1,n */ uni = u[ip] - u[jp]; if (uni < 0.0) { uni = uni + 1.0; } u[ip] = uni; ip = ip - 1; if (ip == 0) { ip = 97; } jp = jp - 1; if (jp == 0) { jp = 97; } c = c - cd; if (c < 0.0) { c = c + cm; } uni = uni - c; if (uni < 0.0) { uni = uni + 1.0; } x[static_cast(ii) - 1] = uni; } /* 40 continue */ } } // end namespace lhs/src/randomLHS.cpp0000644000176200001440000001045213425401602014161 0ustar liggesusers/** * @file randomLHS.cpp * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #include "LHSCommonDefines.h" #include "utilityLHS.h" namespace lhslib { void randomLHS(int n, int k, bclib::matrix & result, bclib::CRandom & oRandom) { std::vector orderVector = std::vector(n); std::vector randomunif1 = std::vector(n); for (int jcol = 0; jcol < k; jcol++) { for (int irow = 0; irow < n; irow++) { randomunif1[irow] = oRandom.getNextRandom(); } bclib::findorder(randomunif1, orderVector); for (int irow = 0; irow < n; irow++) { result(irow,jcol) = orderVector[irow]; } } } void randomLHS(int n, int k, bool bPreserveDraw, bclib::matrix & result, bclib::CRandom & oRandom) { if (n < 1 || k < 1) { throw std::runtime_error("nsamples are less than 1 (n) or nparameters less than 1 (k)"); } msize_type nsamples = static_cast(n); msize_type nparameters = static_cast(k); if (result.rowsize() != nsamples || result.colsize() != nparameters) { throw std::runtime_error("result should be n x k for the lhslib::randomLHS call"); } std::vector randomunif1 = std::vector(n); std::vector randomunif2; std::vector orderVector = std::vector(n); if (bPreserveDraw) { randomunif2 = std::vector(n); for (int jcol = 0; jcol < k; jcol++) { // must be two separate loops for sampling order for (int irow = 0; irow < n; irow++) { randomunif1[irow] = oRandom.getNextRandom(); } // must be two separate loops for sampling order for (int irow = 0; irow < n; irow++) { randomunif2[irow] = oRandom.getNextRandom(); } bclib::findorder_zero(randomunif1, orderVector); for (int irow = 0; irow < n; irow++) { result(irow,jcol) = orderVector[irow] + randomunif2[irow]; result(irow,jcol) /= static_cast(n); } } } else { randomunif2 = std::vector(n*k); for (int jcol = 0; jcol < k; jcol++) { for (int irow = 0; irow < n; irow++) { randomunif1[irow] = oRandom.getNextRandom(); } bclib::findorder_zero(randomunif1, orderVector); for (int irow = 0; irow < n; irow++) { result(irow,jcol) = orderVector[irow]; } } for (int i = 0; i < n*k; i++) { randomunif2[i] = oRandom.getNextRandom(); } // TODO: this might not be the right order!!! bclib::matrix randomMatrix(n, k, randomunif2); for (int jcol = 0; jcol < k; jcol++) { for (int irow = 0; irow < n; irow++) { result(irow,jcol) += randomMatrix(irow, jcol); result(irow,jcol) /= static_cast(n); } } } } } // end namespace lhs/src/oalhs_r.cpp0000644000176200001440000000770213425401602013765 0ustar liggesusers/** * @file oalhs_r.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #include "oalhs_r.h" RcppExport SEXP /*double matrix*/ oa_to_lhs(SEXP /*int*/ n, SEXP /*int*/ k, SEXP /*int matrix*/ oa, SEXP /*bool*/ bverbose) { BEGIN_RCPP Rcpp::IntegerMatrix intoa(oa); if (TYPEOF(n) != INTSXP || TYPEOF(k) != INTSXP) { Rcpp_error("n and k should be integers"); } if (TYPEOF(bverbose) != LGLSXP) { Rcpp_error("bverbose should be a logical"); } int nlocal = Rcpp::as(n); int klocal = Rcpp::as(k); bclib::matrix::size_type m_n = static_cast::size_type>(nlocal); bclib::matrix::size_type m_k = static_cast::size_type>(klocal); bool bverbose_local = Rcpp::as(bverbose); if (nlocal == NA_INTEGER || klocal == NA_INTEGER || bverbose_local == NA_LOGICAL) { Rcpp_error("n, k, and bverbose are not permitted to be NA"); } bclib::matrix oa_local = bclib::matrix(m_n, m_k); oarutils::convertToMatrix(intoa, oa_local); bclib::matrix intlhs_local = bclib::matrix(m_n, m_k); bclib::matrix lhs_local = bclib::matrix(m_n, m_k); lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); Rcpp::NumericMatrix rcppA(nlocal, klocal); oalhslib::oaLHS(nlocal, klocal, oa_local, intlhs_local, lhs_local, bverbose_local, oRStandardUniform); oarutils::convertToRcppMatrix(lhs_local, rcppA); return(rcppA); END_RCPP } RcppExport SEXP /*double matrix*/ create_oalhs(SEXP /*int*/ n, SEXP /*int*/ k, SEXP /*bool*/ bChooseLargerDesign, SEXP /*bool*/ bverbose) { BEGIN_RCPP if (TYPEOF(n) != INTSXP || TYPEOF(k) != INTSXP) { Rcpp_error("n and k should be integers"); } if (TYPEOF(bverbose) != LGLSXP || TYPEOF(bChooseLargerDesign) != LGLSXP) { Rcpp_error("bverbose should be a logical and bChooseLargerDesign should be logical"); } int nlocal = Rcpp::as(n); int klocal = Rcpp::as(k); bclib::matrix::size_type m_n = static_cast::size_type>(nlocal); bclib::matrix::size_type m_k = static_cast::size_type>(klocal); bool bverbose_local = Rcpp::as(bverbose); bool bChooseLargerDesign_local = Rcpp::as(bChooseLargerDesign); if (nlocal == NA_INTEGER || klocal == NA_INTEGER || bverbose_local == NA_LOGICAL || bChooseLargerDesign_local == NA_LOGICAL) { Rcpp_error("n, k, bChooseLargerDesign, and bverbose are not permitted to be NA"); } bclib::matrix oalhs_local = bclib::matrix(m_n, m_k); Rcpp::NumericMatrix rcppA(nlocal, klocal); lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); oalhslib::generateOALHS(nlocal, klocal, oalhs_local, bChooseLargerDesign_local, bverbose_local, oRStandardUniform); oarutils::convertToRcppMatrix(oalhs_local, rcppA); return(rcppA); END_RCPP } lhs/src/rutils.h0000644000176200001440000001231713425401602013323 0ustar liggesusers/** * @file rutils.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef RUTILS_H #define RUTILS_H #include "OACommonDefines.h" #include "runif.h" namespace oacpp { /* Namespace for utilities based on runif */ namespace rutils { /** * In S one just does rank(runif(q)). Here we want * something like rank(runif(q))-1 since the symbols to * be permuted are 0..q-1 * @param pi a vector of integers to be permuted * @param q length of the vector * @param randomClass a random number generator class */ void unifperm( std::vector & pi, int q, RUnif & randomClass ); /** * Find the rank of each vector element (zero based) * * @deprecated This algorithm is slow, but easier to verify * * @tparam T numeric argument that can be ranked * @param v the vector to be ranked * @param indx the ranks of the elements */ template void findranks_slow_zero(const std::vector & v, std::vector & indx) { if (indx.size() != v.size()) { indx.resize(v.size()); } for (size_t i = 0; i < v.size(); i++) { indx[i] = static_cast(i); } std::vector vsort(v); std::sort::iterator>(vsort.begin(), vsort.end()); for (size_t i = 0; i < v.size(); i++) { indx[i] = static_cast(std::find(vsort.begin(), vsort.end(), v[i]) - vsort.begin()); } } /** * Find the rank of each vector element * * @deprecated This algorithm is slow, but easier to verify * * @tparam T numeric argument that can be ranked * @param v the vector to be ranked * @param indx the ranks of the elements */ template void findranks_slow(const std::vector & v, std::vector & indx) { findranks_slow_zero(v, indx); for (size_t i = 0; i < indx.size(); i++) { indx[i] += 1; } } /** * Comparison operator to use in the findranks method * @param first the first pair of arguments (value, rank) * @param second the second pair of arguments (value, rank) * @return true if the value in the first argument is less than the value in the second argument */ template bool findranksCompare(const std::pair first, const std::pair second) { return (first.first < second.first); } /** * Find the rank of each vector element (zero based) * @tparam T numeric argument that can be ranked * @param v the vector to be ranked * @param rank the ranks of the elements */ template void findranks_zero(const std::vector & v, std::vector & rank) { // create a vector of pairs to hold the value and the integer rank std::vector > p(v.size()); std::vector temp(p.size()); for (size_t i = 0; i < v.size(); i++) { p[i] = std::pair(v[i], static_cast(i)); } // if the rank vector is not the right size, resize it (the original values may be lost) if (rank.size() != v.size()) { rank.resize(v.size()); } // sort the pairs of values std::sort(p.begin(), p.end(), findranksCompare); // take the ranks from the pairs and put them in the rank vector for (size_t i = 0; i < v.size(); i++) { rank[p[i].second] = static_cast(i); } } /** * Find the rank of each vector element * @tparam T numeric argument that can be ranked * @param v the vector to be ranked * @param rank the ranks of the elements */ template void findranks(const std::vector & v, std::vector & rank) { findranks_zero(v, rank); for (size_t i = 0; i < rank.size(); i++) { rank[i] += 1; } } } // end namespace } // end namespace #endif lhs/src/xtnset.h0000644000176200001440000006102013425401602013321 0ustar liggesusers/* * NOTE: This file should be excluded from the Doxygen build * * file xtnset.h * author Robert Carnell * copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #ifndef XTNSET_H #define XTNSET_H /* This code was computer generated */ /* GF( 2 ^ 2 ) = GF( 4 ) */ xtn2t2 = std::vector(1+1); xtn2t2[0] = 1; xtn2t2[1] = 1; /* GF( 2 ^ 3 ) = GF( 8 ) */ xtn2t3 = std::vector(1+2); xtn2t3[0] = 1; xtn2t3[1] = 0; xtn2t3[2] = 1; /* GF( 2 ^ 4 ) = GF( 16 ) */ xtn2t4 = std::vector(1+3); xtn2t4[0] = 1; xtn2t4[1] = 0; xtn2t4[2] = 0; xtn2t4[3] = 1; /* GF( 2 ^ 5 ) = GF( 32 ) */ xtn2t5 = std::vector(1+4); xtn2t5[0] = 1; xtn2t5[1] = 0; xtn2t5[2] = 0; xtn2t5[3] = 1; xtn2t5[4] = 0; /* GF( 2 ^ 6 ) = GF( 64 ) */ xtn2t6 = std::vector(1+5); xtn2t6[0] = 1; xtn2t6[1] = 0; xtn2t6[2] = 0; xtn2t6[3] = 0; xtn2t6[4] = 0; xtn2t6[5] = 1; /* GF( 2 ^ 7 ) = GF( 128 ) */ xtn2t7 = std::vector(1+6); xtn2t7[0] = 1; xtn2t7[1] = 0; xtn2t7[2] = 0; xtn2t7[3] = 0; xtn2t7[4] = 0; xtn2t7[5] = 0; xtn2t7[6] = 1; /* GF( 2 ^ 8 ) = GF( 256 ) */ xtn2t8 = std::vector(1+7); xtn2t8[0] = 1; xtn2t8[1] = 0; xtn2t8[2] = 0; xtn2t8[3] = 0; xtn2t8[4] = 1; xtn2t8[5] = 1; xtn2t8[6] = 1; xtn2t8[7] = 0; /* GF( 2 ^ 9 ) = GF( 512 ) */ xtn2t9 = std::vector(1+8); xtn2t9[0] = 1; xtn2t9[1] = 0; xtn2t9[2] = 0; xtn2t9[3] = 0; xtn2t9[4] = 0; xtn2t9[5] = 1; xtn2t9[6] = 0; xtn2t9[7] = 0; xtn2t9[8] = 0; /* GF( 2 ^ 10 ) = GF( 1024 ) */ xtn2t10 = std::vector(1+9); xtn2t10[0] = 1; xtn2t10[1] = 0; xtn2t10[2] = 0; xtn2t10[3] = 0; xtn2t10[4] = 0; xtn2t10[5] = 0; xtn2t10[6] = 0; xtn2t10[7] = 1; xtn2t10[8] = 0; xtn2t10[9] = 0; /* GF( 2 ^ 11 ) = GF( 2048 ) */ xtn2t11 = std::vector(1+10); xtn2t11[0] = 1; xtn2t11[1] = 0; xtn2t11[2] = 0; xtn2t11[3] = 0; xtn2t11[4] = 0; xtn2t11[5] = 0; xtn2t11[6] = 0; xtn2t11[7] = 0; xtn2t11[8] = 0; xtn2t11[9] = 1; xtn2t11[10] = 0; /* GF( 2 ^ 12 ) = GF( 4096 ) */ xtn2t12 = std::vector(1+11); xtn2t12[0] = 1; xtn2t12[1] = 0; xtn2t12[2] = 0; xtn2t12[3] = 0; xtn2t12[4] = 1; xtn2t12[5] = 0; xtn2t12[6] = 0; xtn2t12[7] = 0; xtn2t12[8] = 0; xtn2t12[9] = 0; xtn2t12[10] = 1; xtn2t12[11] = 1; /* GF( 2 ^ 13 ) = GF( 8192 ) */ xtn2t13 = std::vector(1+12); xtn2t13[0] = 1; xtn2t13[1] = 0; xtn2t13[2] = 0; xtn2t13[3] = 0; xtn2t13[4] = 0; xtn2t13[5] = 0; xtn2t13[6] = 0; xtn2t13[7] = 0; xtn2t13[8] = 1; xtn2t13[9] = 0; xtn2t13[10] = 0; xtn2t13[11] = 1; xtn2t13[12] = 1; /* GF( 2 ^ 14 ) = GF( 16384 ) */ xtn2t14 = std::vector(1+13); xtn2t14[0] = 1; xtn2t14[1] = 0; xtn2t14[2] = 1; xtn2t14[3] = 0; xtn2t14[4] = 0; xtn2t14[5] = 0; xtn2t14[6] = 0; xtn2t14[7] = 0; xtn2t14[8] = 0; xtn2t14[9] = 0; xtn2t14[10] = 0; xtn2t14[11] = 0; xtn2t14[12] = 1; xtn2t14[13] = 1; /* GF( 2 ^ 15 ) = GF( 32768 ) */ xtn2t15 = std::vector(1+14); xtn2t15[0] = 1; xtn2t15[1] = 0; xtn2t15[2] = 0; xtn2t15[3] = 0; xtn2t15[4] = 0; xtn2t15[5] = 0; xtn2t15[6] = 0; xtn2t15[7] = 0; xtn2t15[8] = 0; xtn2t15[9] = 0; xtn2t15[10] = 0; xtn2t15[11] = 0; xtn2t15[12] = 0; xtn2t15[13] = 0; xtn2t15[14] = 1; /* GF( 2 ^ 16 ) = GF( 65536 ) */ xtn2t16 = std::vector(1+15); xtn2t16[0] = 1; xtn2t16[1] = 0; xtn2t16[2] = 0; xtn2t16[3] = 0; xtn2t16[4] = 1; xtn2t16[5] = 0; xtn2t16[6] = 0; xtn2t16[7] = 0; xtn2t16[8] = 0; xtn2t16[9] = 0; xtn2t16[10] = 0; xtn2t16[11] = 0; xtn2t16[12] = 0; xtn2t16[13] = 1; xtn2t16[14] = 0; xtn2t16[15] = 1; /* GF( 2 ^ 17 ) = GF( 131072 ) */ xtn2t17 = std::vector(1+16); xtn2t17[0] = 1; xtn2t17[1] = 0; xtn2t17[2] = 0; xtn2t17[3] = 0; xtn2t17[4] = 0; xtn2t17[5] = 0; xtn2t17[6] = 0; xtn2t17[7] = 0; xtn2t17[8] = 0; xtn2t17[9] = 0; xtn2t17[10] = 0; xtn2t17[11] = 0; xtn2t17[12] = 0; xtn2t17[13] = 0; xtn2t17[14] = 1; xtn2t17[15] = 0; xtn2t17[16] = 0; /* GF( 2 ^ 18 ) = GF( 262144 ) */ xtn2t18 = std::vector(1+17); xtn2t18[0] = 1; xtn2t18[1] = 0; xtn2t18[2] = 0; xtn2t18[3] = 0; xtn2t18[4] = 0; xtn2t18[5] = 0; xtn2t18[6] = 0; xtn2t18[7] = 0; xtn2t18[8] = 0; xtn2t18[9] = 0; xtn2t18[10] = 0; xtn2t18[11] = 1; xtn2t18[12] = 0; xtn2t18[13] = 0; xtn2t18[14] = 0; xtn2t18[15] = 0; xtn2t18[16] = 0; xtn2t18[17] = 0; /* GF( 2 ^ 19 ) = GF( 524288 ) */ xtn2t19 = std::vector(1+18); xtn2t19[0] = 1; xtn2t19[1] = 0; xtn2t19[2] = 0; xtn2t19[3] = 0; xtn2t19[4] = 0; xtn2t19[5] = 0; xtn2t19[6] = 0; xtn2t19[7] = 0; xtn2t19[8] = 0; xtn2t19[9] = 0; xtn2t19[10] = 0; xtn2t19[11] = 0; xtn2t19[12] = 0; xtn2t19[13] = 0; xtn2t19[14] = 1; xtn2t19[15] = 0; xtn2t19[16] = 0; xtn2t19[17] = 1; xtn2t19[18] = 1; /* GF( 2 ^ 20 ) = GF( 1048576 ) */ xtn2t20 = std::vector(1+19); xtn2t20[0] = 1; xtn2t20[1] = 0; xtn2t20[2] = 0; xtn2t20[3] = 0; xtn2t20[4] = 0; xtn2t20[5] = 0; xtn2t20[6] = 0; xtn2t20[7] = 0; xtn2t20[8] = 0; xtn2t20[9] = 0; xtn2t20[10] = 0; xtn2t20[11] = 0; xtn2t20[12] = 0; xtn2t20[13] = 0; xtn2t20[14] = 0; xtn2t20[15] = 0; xtn2t20[16] = 0; xtn2t20[17] = 1; xtn2t20[18] = 0; xtn2t20[19] = 0; /* GF( 2 ^ 21 ) = GF( 2097152 ) */ xtn2t21 = std::vector(1+20); xtn2t21[0] = 1; xtn2t21[1] = 0; xtn2t21[2] = 0; xtn2t21[3] = 0; xtn2t21[4] = 0; xtn2t21[5] = 0; xtn2t21[6] = 0; xtn2t21[7] = 0; xtn2t21[8] = 0; xtn2t21[9] = 0; xtn2t21[10] = 0; xtn2t21[11] = 0; xtn2t21[12] = 0; xtn2t21[13] = 0; xtn2t21[14] = 0; xtn2t21[15] = 0; xtn2t21[16] = 0; xtn2t21[17] = 0; xtn2t21[18] = 0; xtn2t21[19] = 1; xtn2t21[20] = 0; /* GF( 2 ^ 22 ) = GF( 4194304 ) */ xtn2t22 = std::vector(1+21); xtn2t22[0] = 1; xtn2t22[1] = 0; xtn2t22[2] = 0; xtn2t22[3] = 0; xtn2t22[4] = 0; xtn2t22[5] = 0; xtn2t22[6] = 0; xtn2t22[7] = 0; xtn2t22[8] = 0; xtn2t22[9] = 0; xtn2t22[10] = 0; xtn2t22[11] = 0; xtn2t22[12] = 0; xtn2t22[13] = 0; xtn2t22[14] = 0; xtn2t22[15] = 0; xtn2t22[16] = 0; xtn2t22[17] = 0; xtn2t22[18] = 0; xtn2t22[19] = 0; xtn2t22[20] = 0; xtn2t22[21] = 1; /* GF( 2 ^ 23 ) = GF( 8388608 ) */ xtn2t23 = std::vector(1+22); xtn2t23[0] = 1; xtn2t23[1] = 0; xtn2t23[2] = 0; xtn2t23[3] = 0; xtn2t23[4] = 0; xtn2t23[5] = 0; xtn2t23[6] = 0; xtn2t23[7] = 0; xtn2t23[8] = 0; xtn2t23[9] = 0; xtn2t23[10] = 0; xtn2t23[11] = 0; xtn2t23[12] = 0; xtn2t23[13] = 0; xtn2t23[14] = 0; xtn2t23[15] = 0; xtn2t23[16] = 0; xtn2t23[17] = 0; xtn2t23[18] = 1; xtn2t23[19] = 0; xtn2t23[20] = 0; xtn2t23[21] = 0; xtn2t23[22] = 0; /* GF( 2 ^ 24 ) = GF( 16777216 ) */ xtn2t24 = std::vector(1+23); xtn2t24[0] = 1; xtn2t24[1] = 0; xtn2t24[2] = 0; xtn2t24[3] = 0; xtn2t24[4] = 0; xtn2t24[5] = 0; xtn2t24[6] = 0; xtn2t24[7] = 0; xtn2t24[8] = 0; xtn2t24[9] = 0; xtn2t24[10] = 0; xtn2t24[11] = 0; xtn2t24[12] = 0; xtn2t24[13] = 0; xtn2t24[14] = 0; xtn2t24[15] = 0; xtn2t24[16] = 0; xtn2t24[17] = 1; xtn2t24[18] = 0; xtn2t24[19] = 0; xtn2t24[20] = 0; xtn2t24[21] = 0; xtn2t24[22] = 1; xtn2t24[23] = 1; /* GF( 2 ^ 25 ) = GF( 33554432 ) */ xtn2t25 = std::vector(1+24); xtn2t25[0] = 1; xtn2t25[1] = 0; xtn2t25[2] = 0; xtn2t25[3] = 0; xtn2t25[4] = 0; xtn2t25[5] = 0; xtn2t25[6] = 0; xtn2t25[7] = 0; xtn2t25[8] = 0; xtn2t25[9] = 0; xtn2t25[10] = 0; xtn2t25[11] = 0; xtn2t25[12] = 0; xtn2t25[13] = 0; xtn2t25[14] = 0; xtn2t25[15] = 0; xtn2t25[16] = 0; xtn2t25[17] = 0; xtn2t25[18] = 0; xtn2t25[19] = 0; xtn2t25[20] = 0; xtn2t25[21] = 0; xtn2t25[22] = 1; xtn2t25[23] = 0; xtn2t25[24] = 0; /* GF( 2 ^ 26 ) = GF( 67108864 ) */ xtn2t26 = std::vector(1+25); xtn2t26[0] = 1; xtn2t26[1] = 0; xtn2t26[2] = 0; xtn2t26[3] = 0; xtn2t26[4] = 0; xtn2t26[5] = 0; xtn2t26[6] = 0; xtn2t26[7] = 0; xtn2t26[8] = 0; xtn2t26[9] = 0; xtn2t26[10] = 0; xtn2t26[11] = 0; xtn2t26[12] = 0; xtn2t26[13] = 0; xtn2t26[14] = 0; xtn2t26[15] = 0; xtn2t26[16] = 0; xtn2t26[17] = 0; xtn2t26[18] = 0; xtn2t26[19] = 0; xtn2t26[20] = 1; xtn2t26[21] = 0; xtn2t26[22] = 0; xtn2t26[23] = 0; xtn2t26[24] = 1; xtn2t26[25] = 1; /* GF( 2 ^ 27 ) = GF( 134217728 ) */ xtn2t27 = std::vector(1+26); xtn2t27[0] = 1; xtn2t27[1] = 0; xtn2t27[2] = 0; xtn2t27[3] = 0; xtn2t27[4] = 0; xtn2t27[5] = 0; xtn2t27[6] = 0; xtn2t27[7] = 0; xtn2t27[8] = 0; xtn2t27[9] = 0; xtn2t27[10] = 0; xtn2t27[11] = 0; xtn2t27[12] = 0; xtn2t27[13] = 0; xtn2t27[14] = 0; xtn2t27[15] = 0; xtn2t27[16] = 0; xtn2t27[17] = 0; xtn2t27[18] = 0; xtn2t27[19] = 0; xtn2t27[20] = 0; xtn2t27[21] = 0; xtn2t27[22] = 1; xtn2t27[23] = 0; xtn2t27[24] = 0; xtn2t27[25] = 1; xtn2t27[26] = 1; /* GF( 2 ^ 28 ) = GF( 268435456 ) */ xtn2t28 = std::vector(1+27); xtn2t28[0] = 1; xtn2t28[1] = 0; xtn2t28[2] = 0; xtn2t28[3] = 0; xtn2t28[4] = 0; xtn2t28[5] = 0; xtn2t28[6] = 0; xtn2t28[7] = 0; xtn2t28[8] = 0; xtn2t28[9] = 0; xtn2t28[10] = 0; xtn2t28[11] = 0; xtn2t28[12] = 0; xtn2t28[13] = 0; xtn2t28[14] = 0; xtn2t28[15] = 0; xtn2t28[16] = 0; xtn2t28[17] = 0; xtn2t28[18] = 0; xtn2t28[19] = 0; xtn2t28[20] = 0; xtn2t28[21] = 0; xtn2t28[22] = 0; xtn2t28[23] = 0; xtn2t28[24] = 0; xtn2t28[25] = 1; xtn2t28[26] = 0; xtn2t28[27] = 0; /* GF( 2 ^ 29 ) = GF( 536870912 ) */ xtn2t29 = std::vector(1+28); xtn2t29[0] = 1; xtn2t29[1] = 0; xtn2t29[2] = 0; xtn2t29[3] = 0; xtn2t29[4] = 0; xtn2t29[5] = 0; xtn2t29[6] = 0; xtn2t29[7] = 0; xtn2t29[8] = 0; xtn2t29[9] = 0; xtn2t29[10] = 0; xtn2t29[11] = 0; xtn2t29[12] = 0; xtn2t29[13] = 0; xtn2t29[14] = 0; xtn2t29[15] = 0; xtn2t29[16] = 0; xtn2t29[17] = 0; xtn2t29[18] = 0; xtn2t29[19] = 0; xtn2t29[20] = 0; xtn2t29[21] = 0; xtn2t29[22] = 0; xtn2t29[23] = 0; xtn2t29[24] = 0; xtn2t29[25] = 0; xtn2t29[26] = 0; xtn2t29[27] = 1; xtn2t29[28] = 0; /* GF( 3 ^ 2 ) = GF( 9 ) */ xtn3t2 = std::vector(1+1); xtn3t2[0] = 1; xtn3t2[1] = 2; /* GF( 3 ^ 3 ) = GF( 27 ) */ xtn3t3 = std::vector(1+2); xtn3t3[0] = 2; xtn3t3[1] = 0; xtn3t3[2] = 1; /* GF( 3 ^ 4 ) = GF( 81 ) */ xtn3t4 = std::vector(1+3); xtn3t4[0] = 1; xtn3t4[1] = 0; xtn3t4[2] = 0; xtn3t4[3] = 2; /* GF( 3 ^ 5 ) = GF( 243 ) */ xtn3t5 = std::vector(1+4); xtn3t5[0] = 2; xtn3t5[1] = 0; xtn3t5[2] = 2; xtn3t5[3] = 0; xtn3t5[4] = 2; /* GF( 3 ^ 6 ) = GF( 729 ) */ xtn3t6 = std::vector(1+5); xtn3t6[0] = 1; xtn3t6[1] = 0; xtn3t6[2] = 0; xtn3t6[3] = 0; xtn3t6[4] = 0; xtn3t6[5] = 2; /* GF( 3 ^ 7 ) = GF( 2187 ) */ xtn3t7 = std::vector(1+6); xtn3t7[0] = 2; xtn3t7[1] = 0; xtn3t7[2] = 0; xtn3t7[3] = 0; xtn3t7[4] = 2; xtn3t7[5] = 0; xtn3t7[6] = 2; /* GF( 3 ^ 8 ) = GF( 6561 ) */ xtn3t8 = std::vector(1+7); xtn3t8[0] = 1; xtn3t8[1] = 0; xtn3t8[2] = 0; xtn3t8[3] = 0; xtn3t8[4] = 0; xtn3t8[5] = 2; xtn3t8[6] = 0; xtn3t8[7] = 0; /* GF( 3 ^ 9 ) = GF( 19683 ) */ xtn3t9 = std::vector(1+8); xtn3t9[0] = 2; xtn3t9[1] = 0; xtn3t9[2] = 0; xtn3t9[3] = 0; xtn3t9[4] = 0; xtn3t9[5] = 2; xtn3t9[6] = 0; xtn3t9[7] = 2; xtn3t9[8] = 0; /* GF( 3 ^ 10 ) = GF( 59049 ) */ xtn3t10 = std::vector(1+9); xtn3t10[0] = 1; xtn3t10[1] = 0; xtn3t10[2] = 0; xtn3t10[3] = 0; xtn3t10[4] = 0; xtn3t10[5] = 0; xtn3t10[6] = 0; xtn3t10[7] = 2; xtn3t10[8] = 0; xtn3t10[9] = 2; /* GF( 3 ^ 11 ) = GF( 177147 ) */ xtn3t11 = std::vector(1+10); xtn3t11[0] = 2; xtn3t11[1] = 0; xtn3t11[2] = 0; xtn3t11[3] = 0; xtn3t11[4] = 2; xtn3t11[5] = 0; xtn3t11[6] = 0; xtn3t11[7] = 0; xtn3t11[8] = 0; xtn3t11[9] = 0; xtn3t11[10] = 2; /* GF( 3 ^ 12 ) = GF( 531441 ) */ xtn3t12 = std::vector(1+11); xtn3t12[0] = 1; xtn3t12[1] = 0; xtn3t12[2] = 0; xtn3t12[3] = 0; xtn3t12[4] = 0; xtn3t12[5] = 0; xtn3t12[6] = 0; xtn3t12[7] = 2; xtn3t12[8] = 0; xtn3t12[9] = 0; xtn3t12[10] = 0; xtn3t12[11] = 2; /* GF( 3 ^ 13 ) = GF( 1594323 ) */ xtn3t13 = std::vector(1+12); xtn3t13[0] = 2; xtn3t13[1] = 0; xtn3t13[2] = 0; xtn3t13[3] = 0; xtn3t13[4] = 0; xtn3t13[5] = 0; xtn3t13[6] = 2; xtn3t13[7] = 0; xtn3t13[8] = 0; xtn3t13[9] = 0; xtn3t13[10] = 0; xtn3t13[11] = 0; xtn3t13[12] = 2; /* GF( 3 ^ 14 ) = GF( 4782969 ) */ xtn3t14 = std::vector(1+13); xtn3t14[0] = 1; xtn3t14[1] = 0; xtn3t14[2] = 0; xtn3t14[3] = 0; xtn3t14[4] = 0; xtn3t14[5] = 0; xtn3t14[6] = 0; xtn3t14[7] = 0; xtn3t14[8] = 0; xtn3t14[9] = 0; xtn3t14[10] = 0; xtn3t14[11] = 0; xtn3t14[12] = 0; xtn3t14[13] = 2; /* GF( 3 ^ 15 ) = GF( 14348907 ) */ xtn3t15 = std::vector(1+14); xtn3t15[0] = 2; xtn3t15[1] = 0; xtn3t15[2] = 0; xtn3t15[3] = 0; xtn3t15[4] = 2; xtn3t15[5] = 0; xtn3t15[6] = 0; xtn3t15[7] = 0; xtn3t15[8] = 0; xtn3t15[9] = 0; xtn3t15[10] = 0; xtn3t15[11] = 0; xtn3t15[12] = 0; xtn3t15[13] = 0; xtn3t15[14] = 2; /* GF( 3 ^ 16 ) = GF( 43046721 ) */ xtn3t16 = std::vector(1+15); xtn3t16[0] = 1; xtn3t16[1] = 0; xtn3t16[2] = 0; xtn3t16[3] = 0; xtn3t16[4] = 0; xtn3t16[5] = 0; xtn3t16[6] = 0; xtn3t16[7] = 0; xtn3t16[8] = 0; xtn3t16[9] = 2; xtn3t16[10] = 0; xtn3t16[11] = 0; xtn3t16[12] = 0; xtn3t16[13] = 0; xtn3t16[14] = 0; xtn3t16[15] = 0; /* GF( 3 ^ 17 ) = GF( 129140163 ) */ xtn3t17 = std::vector(1+16); xtn3t17[0] = 2; xtn3t17[1] = 0; xtn3t17[2] = 0; xtn3t17[3] = 0; xtn3t17[4] = 0; xtn3t17[5] = 0; xtn3t17[6] = 0; xtn3t17[7] = 0; xtn3t17[8] = 2; xtn3t17[9] = 0; xtn3t17[10] = 0; xtn3t17[11] = 0; xtn3t17[12] = 0; xtn3t17[13] = 0; xtn3t17[14] = 0; xtn3t17[15] = 0; xtn3t17[16] = 2; /* GF( 3 ^ 18 ) = GF( 387420489 ) */ xtn3t18 = std::vector(1+17); xtn3t18[0] = 1; xtn3t18[1] = 0; xtn3t18[2] = 0; xtn3t18[3] = 0; xtn3t18[4] = 0; xtn3t18[5] = 2; xtn3t18[6] = 0; xtn3t18[7] = 0; xtn3t18[8] = 0; xtn3t18[9] = 0; xtn3t18[10] = 0; xtn3t18[11] = 0; xtn3t18[12] = 0; xtn3t18[13] = 0; xtn3t18[14] = 0; xtn3t18[15] = 0; xtn3t18[16] = 0; xtn3t18[17] = 2; /* GF( 5 ^ 2 ) = GF( 25 ) */ xtn5t2 = std::vector(1+1); xtn5t2[0] = 3; xtn5t2[1] = 4; /* GF( 5 ^ 3 ) = GF( 125 ) */ xtn5t3 = std::vector(1+2); xtn5t3[0] = 3; xtn5t3[1] = 0; xtn5t3[2] = 4; /* GF( 5 ^ 4 ) = GF( 625 ) */ xtn5t4 = std::vector(1+3); xtn5t4[0] = 2; xtn5t4[1] = 4; xtn5t4[2] = 0; xtn5t4[3] = 4; /* GF( 5 ^ 5 ) = GF( 3125 ) */ xtn5t5 = std::vector(1+4); xtn5t5[0] = 3; xtn5t5[1] = 0; xtn5t5[2] = 4; xtn5t5[3] = 0; xtn5t5[4] = 0; /* GF( 5 ^ 6 ) = GF( 15625 ) */ xtn5t6 = std::vector(1+5); xtn5t6[0] = 3; xtn5t6[1] = 0; xtn5t6[2] = 0; xtn5t6[3] = 0; xtn5t6[4] = 0; xtn5t6[5] = 4; /* GF( 5 ^ 7 ) = GF( 78125 ) */ xtn5t7 = std::vector(1+6); xtn5t7[0] = 3; xtn5t7[1] = 0; xtn5t7[2] = 0; xtn5t7[3] = 0; xtn5t7[4] = 0; xtn5t7[5] = 0; xtn5t7[6] = 4; /* GF( 5 ^ 8 ) = GF( 390625 ) */ xtn5t8 = std::vector(1+7); xtn5t8[0] = 2; xtn5t8[1] = 0; xtn5t8[2] = 0; xtn5t8[3] = 4; xtn5t8[4] = 0; xtn5t8[5] = 4; xtn5t8[6] = 0; xtn5t8[7] = 0; /* GF( 5 ^ 9 ) = GF( 1953125 ) */ xtn5t9 = std::vector(1+8); xtn5t9[0] = 2; xtn5t9[1] = 0; xtn5t9[2] = 0; xtn5t9[3] = 0; xtn5t9[4] = 0; xtn5t9[5] = 0; xtn5t9[6] = 4; xtn5t9[7] = 4; xtn5t9[8] = 0; /* GF( 5 ^ 10 ) = GF( 9765625 ) */ xtn5t10 = std::vector(1+9); xtn5t10[0] = 2; xtn5t10[1] = 0; xtn5t10[2] = 0; xtn5t10[3] = 0; xtn5t10[4] = 0; xtn5t10[5] = 0; xtn5t10[6] = 0; xtn5t10[7] = 4; xtn5t10[8] = 0; xtn5t10[9] = 4; /* GF( 5 ^ 11 ) = GF( 48828125 ) */ xtn5t11 = std::vector(1+10); xtn5t11[0] = 3; xtn5t11[1] = 0; xtn5t11[2] = 0; xtn5t11[3] = 0; xtn5t11[4] = 0; xtn5t11[5] = 0; xtn5t11[6] = 0; xtn5t11[7] = 0; xtn5t11[8] = 0; xtn5t11[9] = 0; xtn5t11[10] = 4; /* GF( 5 ^ 12 ) = GF( 244140625 ) */ xtn5t12 = std::vector(1+11); xtn5t12[0] = 2; xtn5t12[1] = 0; xtn5t12[2] = 0; xtn5t12[3] = 0; xtn5t12[4] = 4; xtn5t12[5] = 0; xtn5t12[6] = 0; xtn5t12[7] = 4; xtn5t12[8] = 0; xtn5t12[9] = 0; xtn5t12[10] = 0; xtn5t12[11] = 0; /* GF( 7 ^ 2 ) = GF( 49 ) */ xtn7t2 = std::vector(1+1); xtn7t2[0] = 4; xtn7t2[1] = 6; /* GF( 7 ^ 3 ) = GF( 343 ) */ xtn7t3 = std::vector(1+2); xtn7t3[0] = 5; xtn7t3[1] = 6; xtn7t3[2] = 6; /* GF( 7 ^ 4 ) = GF( 2401 ) */ xtn7t4 = std::vector(1+3); xtn7t4[0] = 4; xtn7t4[1] = 0; xtn7t4[2] = 6; xtn7t4[3] = 6; /* GF( 7 ^ 5 ) = GF( 16807 ) */ xtn7t5 = std::vector(1+4); xtn7t5[0] = 3; xtn7t5[1] = 0; xtn7t5[2] = 0; xtn7t5[3] = 0; xtn7t5[4] = 6; /* GF( 7 ^ 6 ) = GF( 117649 ) */ xtn7t6 = std::vector(1+5); xtn7t6[0] = 4; xtn7t6[1] = 0; xtn7t6[2] = 0; xtn7t6[3] = 0; xtn7t6[4] = 6; xtn7t6[5] = 6; /* GF( 7 ^ 7 ) = GF( 823543 ) */ xtn7t7 = std::vector(1+6); xtn7t7[0] = 3; xtn7t7[1] = 0; xtn7t7[2] = 0; xtn7t7[3] = 0; xtn7t7[4] = 0; xtn7t7[5] = 6; xtn7t7[6] = 0; /* GF( 7 ^ 8 ) = GF( 5764801 ) */ xtn7t8 = std::vector(1+7); xtn7t8[0] = 4; xtn7t8[1] = 0; xtn7t8[2] = 0; xtn7t8[3] = 0; xtn7t8[4] = 0; xtn7t8[5] = 0; xtn7t8[6] = 0; xtn7t8[7] = 6; /* GF( 7 ^ 9 ) = GF( 40353607 ) */ xtn7t9 = std::vector(1+8); xtn7t9[0] = 5; xtn7t9[1] = 0; xtn7t9[2] = 0; xtn7t9[3] = 6; xtn7t9[4] = 0; xtn7t9[5] = 0; xtn7t9[6] = 0; xtn7t9[7] = 0; xtn7t9[8] = 6; /* GF( 7 ^ 10 ) = GF( 282475249 ) */ xtn7t10 = std::vector(1+9); xtn7t10[0] = 4; xtn7t10[1] = 0; xtn7t10[2] = 0; xtn7t10[3] = 0; xtn7t10[4] = 0; xtn7t10[5] = 0; xtn7t10[6] = 0; xtn7t10[7] = 0; xtn7t10[8] = 6; xtn7t10[9] = 6; /* GF( 11 ^ 2 ) = GF( 121 ) */ xtn11t2 = std::vector(1+1); xtn11t2[0] = 4; xtn11t2[1] = 10; /* GF( 11 ^ 3 ) = GF( 1331 ) */ xtn11t3 = std::vector(1+2); xtn11t3[0] = 6; xtn11t3[1] = 0; xtn11t3[2] = 10; /* GF( 11 ^ 4 ) = GF( 14641 ) */ xtn11t4 = std::vector(1+3); xtn11t4[0] = 9; xtn11t4[1] = 10; xtn11t4[2] = 0; xtn11t4[3] = 0; /* GF( 11 ^ 5 ) = GF( 161051 ) */ xtn11t5 = std::vector(1+4); xtn11t5[0] = 2; xtn11t5[1] = 0; xtn11t5[2] = 10; xtn11t5[3] = 10; xtn11t5[4] = 0; /* GF( 11 ^ 6 ) = GF( 1771561 ) */ xtn11t6 = std::vector(1+5); xtn11t6[0] = 4; xtn11t6[1] = 10; xtn11t6[2] = 0; xtn11t6[3] = 0; xtn11t6[4] = 0; xtn11t6[5] = 10; /* GF( 11 ^ 7 ) = GF( 19487171 ) */ xtn11t7 = std::vector(1+6); xtn11t7[0] = 6; xtn11t7[1] = 0; xtn11t7[2] = 0; xtn11t7[3] = 0; xtn11t7[4] = 0; xtn11t7[5] = 0; xtn11t7[6] = 10; /* GF( 11 ^ 8 ) = GF( 214358881 ) */ xtn11t8 = std::vector(1+7); xtn11t8[0] = 9; xtn11t8[1] = 10; xtn11t8[2] = 0; xtn11t8[3] = 0; xtn11t8[4] = 10; xtn11t8[5] = 0; xtn11t8[6] = 0; xtn11t8[7] = 0; /* GF( 13 ^ 2 ) = GF( 169 ) */ xtn13t2 = std::vector(1+1); xtn13t2[0] = 11; xtn13t2[1] = 12; /* GF( 13 ^ 3 ) = GF( 2197 ) */ xtn13t3 = std::vector(1+2); xtn13t3[0] = 6; xtn13t3[1] = 0; xtn13t3[2] = 12; /* GF( 13 ^ 4 ) = GF( 28561 ) */ xtn13t4 = std::vector(1+3); xtn13t4[0] = 11; xtn13t4[1] = 12; xtn13t4[2] = 0; xtn13t4[3] = 12; /* GF( 13 ^ 5 ) = GF( 371293 ) */ xtn13t5 = std::vector(1+4); xtn13t5[0] = 2; xtn13t5[1] = 12; xtn13t5[2] = 0; xtn13t5[3] = 12; xtn13t5[4] = 0; /* GF( 13 ^ 6 ) = GF( 4826809 ) */ xtn13t6 = std::vector(1+5); xtn13t6[0] = 7; xtn13t6[1] = 0; xtn13t6[2] = 0; xtn13t6[3] = 12; xtn13t6[4] = 0; xtn13t6[5] = 12; /* GF( 13 ^ 7 ) = GF( 62748517 ) */ xtn13t7 = std::vector(1+6); xtn13t7[0] = 7; xtn13t7[1] = 0; xtn13t7[2] = 0; xtn13t7[3] = 0; xtn13t7[4] = 12; xtn13t7[5] = 0; xtn13t7[6] = 0; /* GF( 13 ^ 8 ) = GF( 815730721 ) */ xtn13t8 = std::vector(1+7); xtn13t8[0] = 11; xtn13t8[1] = 0; xtn13t8[2] = 0; xtn13t8[3] = 0; xtn13t8[4] = 0; xtn13t8[5] = 12; xtn13t8[6] = 12; xtn13t8[7] = 0; /* GF( 17 ^ 2 ) = GF( 289 ) */ xtn17t2 = std::vector(1+1); xtn17t2[0] = 14; xtn17t2[1] = 16; /* GF( 17 ^ 3 ) = GF( 4913 ) */ xtn17t3 = std::vector(1+2); xtn17t3[0] = 3; xtn17t3[1] = 16; xtn17t3[2] = 0; /* GF( 17 ^ 4 ) = GF( 83521 ) */ xtn17t4 = std::vector(1+3); xtn17t4[0] = 12; xtn17t4[1] = 0; xtn17t4[2] = 0; xtn17t4[3] = 16; /* GF( 17 ^ 5 ) = GF( 1419857 ) */ xtn17t5 = std::vector(1+4); xtn17t5[0] = 3; xtn17t5[1] = 0; xtn17t5[2] = 0; xtn17t5[3] = 0; xtn17t5[4] = 16; /* GF( 17 ^ 6 ) = GF( 24137569 ) */ xtn17t6 = std::vector(1+5); xtn17t6[0] = 14; xtn17t6[1] = 0; xtn17t6[2] = 0; xtn17t6[3] = 0; xtn17t6[4] = 0; xtn17t6[5] = 16; /* GF( 17 ^ 7 ) = GF( 410338673 ) */ xtn17t7 = std::vector(1+6); xtn17t7[0] = 3; xtn17t7[1] = 0; xtn17t7[2] = 0; xtn17t7[3] = 16; xtn17t7[4] = 0; xtn17t7[5] = 0; xtn17t7[6] = 0; /* GF( 19 ^ 2 ) = GF( 361 ) */ xtn19t2 = std::vector(1+1); xtn19t2[0] = 17; xtn19t2[1] = 18; /* GF( 19 ^ 3 ) = GF( 6859 ) */ xtn19t3 = std::vector(1+2); xtn19t3[0] = 3; xtn19t3[1] = 0; xtn19t3[2] = 18; /* GF( 19 ^ 4 ) = GF( 130321 ) */ xtn19t4 = std::vector(1+3); xtn19t4[0] = 17; xtn19t4[1] = 0; xtn19t4[2] = 0; xtn19t4[3] = 18; /* GF( 19 ^ 5 ) = GF( 2476099 ) */ xtn19t5 = std::vector(1+4); xtn19t5[0] = 3; xtn19t5[1] = 18; xtn19t5[2] = 0; xtn19t5[3] = 0; xtn19t5[4] = 0; /* GF( 19 ^ 6 ) = GF( 47045881 ) */ xtn19t6 = std::vector(1+5); xtn19t6[0] = 16; xtn19t6[1] = 18; xtn19t6[2] = 0; xtn19t6[3] = 0; xtn19t6[4] = 0; xtn19t6[5] = 0; /* GF( 19 ^ 7 ) = GF( 893871739 ) */ xtn19t7 = std::vector(1+6); xtn19t7[0] = 10; xtn19t7[1] = 0; xtn19t7[2] = 0; xtn19t7[3] = 0; xtn19t7[4] = 0; xtn19t7[5] = 18; xtn19t7[6] = 0; /* GF( 23 ^ 2 ) = GF( 529 ) */ xtn23t2 = std::vector(1+1); xtn23t2[0] = 16; xtn23t2[1] = 22; /* GF( 23 ^ 3 ) = GF( 12167 ) */ xtn23t3 = std::vector(1+2); xtn23t3[0] = 7; xtn23t3[1] = 0; xtn23t3[2] = 22; /* GF( 23 ^ 4 ) = GF( 279841 ) */ xtn23t4 = std::vector(1+3); xtn23t4[0] = 12; xtn23t4[1] = 22; xtn23t4[2] = 0; xtn23t4[3] = 0; /* GF( 23 ^ 5 ) = GF( 6436343 ) */ xtn23t5 = std::vector(1+4); xtn23t5[0] = 5; xtn23t5[1] = 0; xtn23t5[2] = 0; xtn23t5[3] = 0; xtn23t5[4] = 22; /* GF( 23 ^ 6 ) = GF( 148035889 ) */ xtn23t6 = std::vector(1+5); xtn23t6[0] = 16; xtn23t6[1] = 0; xtn23t6[2] = 0; xtn23t6[3] = 0; xtn23t6[4] = 0; xtn23t6[5] = 22; /* GF( 29 ^ 2 ) = GF( 841 ) */ xtn29t2 = std::vector(1+1); xtn29t2[0] = 26; xtn29t2[1] = 28; /* GF( 29 ^ 3 ) = GF( 24389 ) */ xtn29t3 = std::vector(1+2); xtn29t3[0] = 11; xtn29t3[1] = 28; xtn29t3[2] = 0; /* GF( 29 ^ 4 ) = GF( 707281 ) */ xtn29t4 = std::vector(1+3); xtn29t4[0] = 27; xtn29t4[1] = 0; xtn29t4[2] = 0; xtn29t4[3] = 28; /* GF( 29 ^ 5 ) = GF( 20511149 ) */ xtn29t5 = std::vector(1+4); xtn29t5[0] = 3; xtn29t5[1] = 0; xtn29t5[2] = 0; xtn29t5[3] = 28; xtn29t5[4] = 0; /* GF( 29 ^ 6 ) = GF( 594823321 ) */ xtn29t6 = std::vector(1+5); xtn29t6[0] = 26; xtn29t6[1] = 28; xtn29t6[2] = 0; xtn29t6[3] = 0; xtn29t6[4] = 0; xtn29t6[5] = 0; /* GF( 31 ^ 2 ) = GF( 961 ) */ xtn31t2 = std::vector(1+1); xtn31t2[0] = 19; xtn31t2[1] = 30; /* GF( 31 ^ 3 ) = GF( 29791 ) */ xtn31t3 = std::vector(1+2); xtn31t3[0] = 3; xtn31t3[1] = 30; xtn31t3[2] = 0; /* GF( 31 ^ 4 ) = GF( 923521 ) */ xtn31t4 = std::vector(1+3); xtn31t4[0] = 18; xtn31t4[1] = 0; xtn31t4[2] = 0; xtn31t4[3] = 30; /* GF( 31 ^ 5 ) = GF( 28629151 ) */ xtn31t5 = std::vector(1+4); xtn31t5[0] = 11; xtn31t5[1] = 0; xtn31t5[2] = 0; xtn31t5[3] = 30; xtn31t5[4] = 0; /* GF( 31 ^ 6 ) = GF( 887503681 ) */ xtn31t6 = std::vector(1+5); xtn31t6[0] = 19; xtn31t6[1] = 0; xtn31t6[2] = 0; xtn31t6[3] = 0; xtn31t6[4] = 0; xtn31t6[5] = 30; /* GF( 37 ^ 2 ) = GF( 1369 ) */ xtn37t2 = std::vector(1+1); xtn37t2[0] = 32; xtn37t2[1] = 36; /* GF( 37 ^ 3 ) = GF( 50653 ) */ xtn37t3 = std::vector(1+2); xtn37t3[0] = 13; xtn37t3[1] = 0; xtn37t3[2] = 36; /* GF( 37 ^ 4 ) = GF( 1874161 ) */ xtn37t4 = std::vector(1+3); xtn37t4[0] = 35; xtn37t4[1] = 36; xtn37t4[2] = 0; xtn37t4[3] = 0; /* GF( 37 ^ 5 ) = GF( 69343957 ) */ xtn37t5 = std::vector(1+4); xtn37t5[0] = 5; xtn37t5[1] = 36; xtn37t5[2] = 0; xtn37t5[3] = 0; xtn37t5[4] = 0; /* GF( 41 ^ 2 ) = GF( 1681 ) */ xtn41t2 = std::vector(1+1); xtn41t2[0] = 29; xtn41t2[1] = 40; /* GF( 41 ^ 3 ) = GF( 68921 ) */ xtn41t3 = std::vector(1+2); xtn41t3[0] = 6; xtn41t3[1] = 40; xtn41t3[2] = 0; /* GF( 41 ^ 4 ) = GF( 2825761 ) */ xtn41t4 = std::vector(1+3); xtn41t4[0] = 24; xtn41t4[1] = 40; xtn41t4[2] = 0; xtn41t4[3] = 0; /* GF( 41 ^ 5 ) = GF( 115856201 ) */ xtn41t5 = std::vector(1+4); xtn41t5[0] = 6; xtn41t5[1] = 0; xtn41t5[2] = 0; xtn41t5[3] = 0; xtn41t5[4] = 40; /* GF( 43 ^ 2 ) = GF( 1849 ) */ xtn43t2 = std::vector(1+1); xtn43t2[0] = 40; xtn43t2[1] = 42; /* GF( 43 ^ 3 ) = GF( 79507 ) */ xtn43t3 = std::vector(1+2); xtn43t3[0] = 3; xtn43t3[1] = 42; xtn43t3[2] = 0; /* GF( 43 ^ 4 ) = GF( 3418801 ) */ xtn43t4 = std::vector(1+3); xtn43t4[0] = 23; xtn43t4[1] = 42; xtn43t4[2] = 0; xtn43t4[3] = 0; /* GF( 43 ^ 5 ) = GF( 147008443 ) */ xtn43t5 = std::vector(1+4); xtn43t5[0] = 3; xtn43t5[1] = 0; xtn43t5[2] = 0; xtn43t5[3] = 0; xtn43t5[4] = 42; /* GF( 47 ^ 2 ) = GF( 2209 ) */ xtn47t2 = std::vector(1+1); xtn47t2[0] = 34; xtn47t2[1] = 46; /* GF( 47 ^ 3 ) = GF( 103823 ) */ xtn47t3 = std::vector(1+2); xtn47t3[0] = 5; xtn47t3[1] = 0; xtn47t3[2] = 46; /* GF( 47 ^ 4 ) = GF( 4879681 ) */ xtn47t4 = std::vector(1+3); xtn47t4[0] = 42; xtn47t4[1] = 0; xtn47t4[2] = 0; xtn47t4[3] = 46; /* GF( 47 ^ 5 ) = GF( 229345007 ) */ xtn47t5 = std::vector(1+4); xtn47t5[0] = 5; xtn47t5[1] = 46; xtn47t5[2] = 0; xtn47t5[3] = 0; xtn47t5[4] = 0; #endif lhs/src/RStandardUniform.h0000644000176200001440000000257413425401602015227 0ustar liggesusers/** * @file RStandardUniform.h * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #ifndef RSTANDARDUNIFORM_H #define RSTANDARDUNIFORM_H #include #include "CRandom.h" namespace lhs_r { /** * Standard Uniform random number generator using R */ class RStandardUniform : public bclib::CRandom { public: /** * get the next random number * @return the random deviate */ double getNextRandom() { return Rcpp::as(Rcpp::runif(1)); }; }; } #endif /* RSTANDARDUNIFORM_H */ lhs/src/Makevars.win0000644000176200001440000000005013425401602014107 0ustar liggesusersPKG_CPPFLAGS=-DRCOMPILE CXX_STD = CXX11 lhs/src/init.c0000644000176200001440000000274213425401602012740 0ustar liggesusers#include #include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .Call calls */ extern SEXP create_oalhs(SEXP, SEXP, SEXP, SEXP); extern SEXP geneticLHS_cpp(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP improvedLHS_cpp(SEXP, SEXP, SEXP); extern SEXP maximinLHS_cpp(SEXP, SEXP, SEXP); extern SEXP oa_to_lhs(SEXP, SEXP, SEXP, SEXP); extern SEXP oa_type1(SEXP, SEXP, SEXP, SEXP); extern SEXP oa_type2(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP optimumLHS_cpp(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP optSeededLHS_cpp(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP randomLHS_cpp(SEXP, SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"create_oalhs", (DL_FUNC) &create_oalhs, 4}, {"geneticLHS_cpp", (DL_FUNC) &geneticLHS_cpp, 7}, {"improvedLHS_cpp", (DL_FUNC) &improvedLHS_cpp, 3}, {"maximinLHS_cpp", (DL_FUNC) &maximinLHS_cpp, 3}, {"oa_to_lhs", (DL_FUNC) &oa_to_lhs, 4}, {"oa_type1", (DL_FUNC) &oa_type1, 4}, {"oa_type2", (DL_FUNC) &oa_type2, 5}, {"optimumLHS_cpp", (DL_FUNC) &optimumLHS_cpp, 5}, {"optSeededLHS_cpp", (DL_FUNC) &optSeededLHS_cpp, 6}, {"randomLHS_cpp", (DL_FUNC) &randomLHS_cpp, 3}, {NULL, NULL, 0} }; void R_init_lhs(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } lhs/src/utilityLHS.h0000644000176200001440000003123513425401602014053 0ustar liggesusers/** * @file utilityLHS.h * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #ifndef UTILITYLHS_H #define UTILITYLHS_H #include "LHSCommonDefines.h" namespace lhslib { /** * is the Latin hypercube sample valid * @param result the latin hypercube sample with integer values * @return the result of the validity check */ bool isValidLHS(const bclib::matrix & result); /** * is the Latin hypercube sample valid? * @param result the latin hypercube sample * @return the result of the validity check */ bool isValidLHS(const bclib::matrix & result); /** * rank a vector of objects * @param toRank the vector of objects to rank * @param ranks the ranks of the vector of values * @tparam the type of element in the vectors */ template void rank(const std::vector & toRank, std::vector & ranks) { if (toRank.size() != ranks.size()) { ranks.resize(toRank.size(), 0); } typename std::vector::const_iterator toRank_it1; typename std::vector::const_iterator toRank_it2; std::vector::iterator ranks_it; for (toRank_it1 = toRank.begin(), ranks_it = ranks.begin(); toRank_it1 != toRank.end(), ranks_it != ranks.end(); ++toRank_it1, ++ranks_it) { *ranks_it = 0; for (toRank_it2 = toRank.begin(); toRank_it2 != toRank.end(); ++toRank_it2) { if (*toRank_it1 < *toRank_it2) { (*ranks_it)++; } } } } /** * Initialize the matrix of available points * @param avail the matrix of available points */ void initializeAvailableMatrix(bclib::matrix & avail); /** * print the Latin hypercube sample * @param A the matrix to print * @tparam T the type of matrix to print */ template void lhsPrint(const bclib::matrix & A) { PRINT_MACRO << "\n"; msize_type cols = A.colsize(); msize_type rows = A.rowsize(); for (msize_type irow = 0; irow < rows; irow++) { for (msize_type jcol = 0; jcol < cols; jcol++) { PRINT_MACRO << A(irow, jcol) << ", "; } PRINT_MACRO << "\n"; } } /** * calculate the squared distance between two values. * A type of std::binar_function. * @tparam T the type of values for the Arg1, Arg2, and return */ template struct squareDifference : public std::binary_function /*arg1, arg2, return */ { /** * Calculate the squared distance between two values * @param x Arg1 * @param y Arg2 * @return the (x-y)*(x-y) */ T operator()(const T & x, const T & y) const { return (x-y) * (x-y); } }; /** * Calculate the total squared distance between two vectors * @param A the first vector * @param B the second vector * @tparam T the type of the objects in the vector * @return the total squared distance */ template T calculateDistanceSquared(const std::vector A, const std::vector B) { if (A.size() != B.size()) { throw std::runtime_error("Inputs of a different size"); } // sum = sum + (a-b)*(a-b) T sum = std::inner_product(A.begin(), A.end(), B.begin(), static_cast(0), std::plus(), squareDifference()); return sum; } /** * Calculate the distance squared between two sequence of numbers * * this was primarily implemented to be able to calculate distances between rows * of a matrix without having to copy those rows out * * @param Abegin the beginning of the first iterator * @param Aend the end of the first iterator * @param Bbegin the beginning of the second iterator * @tparam T the type of object de-referenced by the iterator * @tparam ISROWWISE a boolean to indicate if the iterator operates row-wise in the matrix * @return the distance squared */ template T calculateDistanceSquared(const typename bclib::matrixConstIter Abegin, const typename bclib::matrixConstIter Aend, const typename bclib::matrixConstIter Bbegin) { // sum = sum + (a-b)*(a-b) T sum = std::inner_product(Abegin, Aend, Bbegin, static_cast(0), std::plus(), squareDifference()); return sum; } /** * Calculate the distance between the rows of a matrix * @param mat the matrix to calculate distances on * @param result the matrix to hold the results of the calculation * @tparam T the type of object in the matrix */ template void calculateDistance(const bclib::matrix & mat, bclib::matrix & result) { msize_type m_rows = mat.rowsize(); if (result.rowsize() != m_rows || result.colsize() != m_rows) { result = bclib::matrix(m_rows, m_rows); } for (msize_type i = 0; i < m_rows - 1; i++) { for (msize_type j = i+1; j < m_rows; j++) { typename bclib::matrix::const_rowwise_iterator rowi_begin = mat.rowwisebegin(i); typename bclib::matrix::const_rowwise_iterator rowi_end = mat.rowwiseend(i); typename bclib::matrix::const_rowwise_iterator rowj_begin = mat.rowwisebegin(j); T sum = calculateDistanceSquared(rowi_begin, rowi_end, rowj_begin); result(i,j) = sqrt(static_cast(sum)); } } } /** * A unary_function to invert a number in a STL algorithm * @tparam T the type of number to invert * @tparam W the type of the result. (normally a double or float) */ template struct invert : public std::unary_function /*arg1, return */ { /** * A unary_function to invert a number * @param x the object to invert * @return the inverse of x */ W operator()(const T & x) const { if (x != static_cast(0)) { return 1.0 / static_cast(x); } else { return static_cast(x); } } }; /** * sum of the inverse distance between points in a matrix * @param A the matrix * @tparam T the type of object contained in the matrix * @return the sum of the inverse distance between points */ template double sumInvDistance(const bclib::matrix & A) { // create a matrix to hold the distances bclib::matrix dist = bclib::matrix(A.rowsize(), A.rowsize()); // calculate the distances between the rows of A calculateDistance(A, dist); // invert all the distances std::transform::iterator>(dist.begin(), dist.end(), dist.begin(), invert()); // sum the inverted double totalInvDistance = std::accumulate::iterator>(dist.begin(), dist.end(), 0.0); return totalInvDistance; } /** * Sum of the inverse distance between points * @param A the matrix to sum * @tparam T the type of object in the matrix * @return the sum of the inverse distance between points */ template double sumInvDistance_deprecated(const bclib::matrix & A) { msize_type nr = A.rowsize(); msize_type nc = A.colsize(); T oneDistance; T diff; double totalInvDistance = 0.0; /* iterate the row of the first point from 0 to N-2 */ for (msize_type irow = 0; irow < nr - 1; irow++) { /* iterate the row the second point from i+1 to N-1 */ for (msize_type jrow = (irow + 1); jrow < nr; jrow++) { oneDistance = static_cast(0); /* iterate through the columns, summing the squared differences */ for (msize_type kcol = 0; kcol < nc; kcol++) { /* calculate the square of the difference in one dimension between the * points */ diff = A(irow,kcol) - A(jrow,kcol); oneDistance += diff * diff; } /* sum the inverse distances */ if (oneDistance != 0) { totalInvDistance += (1.0 / sqrt(static_cast(oneDistance))); } } } return totalInvDistance; } /** * Copy a matrix * @param copyTo the matrix to copy to * @param copyFrom the matrix to copy from * @tparam the type of object contained in the matrix */ template void copyMatrix(bclib::matrix & copyTo, const bclib::matrix & copyFrom) { if (copyFrom.rowsize() != copyTo.rowsize() || copyFrom.colsize() != copyTo.colsize() || copyFrom.isTransposed() != copyTo.isTransposed()) { throw std::runtime_error("Matrices are not compatible for a copy"); } std::copy::const_iterator, typename bclib::matrix::iterator>(copyFrom.begin(), copyFrom.end(), copyTo.begin()); } /** * Calculate the S optimality measure * @param mat the matrix to calculate S optimality for * @tparam the type of object contained in the matrix * @return the S optimality measure */ template double calculateSOptimal(const bclib::matrix & mat) { // B[i] <- 1/sum(1/dist(A[, , i])) double sum = sumInvDistance(mat); return 1.0 / sum; } /** * Create a vector of random values on (0,1) * @param n the number of random values * @param output the output vector of random values * @param oRandom the pseudo random number generator */ void runif_std(unsigned int n, std::vector & output, bclib::CRandom & oRandom); /** * Create a vector of random integer like values * @param n the length of the random vector * @param min the minimum integer value * @param max the maximum integer value * @param output the output vector of values * @param oRandom the pseudo random number generator. * @tparam T1 the integer valued type like int, unsigned int, long, long long, unsigned long */ template void runifint(unsigned int n, T1 min, T1 max, std::vector & output, bclib::CRandom & oRandom) { if (output.size() != n) { output.resize(n); } std::vector r = std::vector(n); runif_std(n, r, oRandom); typename std::vector::iterator output_it; std::vector::iterator r_it; double range = static_cast(max) + 1.0 - static_cast(min); for (output_it = output.begin(), r_it = r.begin(); output_it != output.end() && r_it != r.end(); ++output_it, ++r_it) { *output_it = min + static_cast(floor((*r_it) * range)); } } /** * Create a random integer like values * @param min the minimum integer value * @param max the maximum integer value * @param output the output value * @param oRandom the pseudo random number generator * @tparam T1 the integer valued type like int, unsigned int, long, long long, unsigned long */ template void runifint(T1 min, T1 max, T1 * output, bclib::CRandom & oRandom) { double r = oRandom.getNextRandom(); double range = static_cast(max) + 1.0 - static_cast(min); *output = min + static_cast(floor((r * range))); } } // end namespace #endif /* UTILITYLHS_H */ lhs/src/akn.cpp0000644000176200001440000003615613425401602013114 0ustar liggesusers/** * @file akn.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "ak.h" namespace oacpp { namespace oaaddelkemp { int addelkempncheck(int q, int p, int akn, int ncol) // LCOV_EXCL_START { std::ostringstream msg; if (akn < 2) { msg << "This Addelman-Kempthorne OA(2q^n,ncol,q,2) is only available for n >= 2. n = " << akn << " was requested.\n"; const std::string ss = msg.str(); throw std::runtime_error(ss.c_str()); } if (p == 2 && q > 4) { msg << "This Addelman-Kempthorne OA(2q^n,ncol,q,2) is only available for odd prime powers q and for even prime \n powers q<=4. \n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } if (ncol > 2 * (primes::ipow(q, akn) - 1) / (q - 1) - 1) { msg << "The Addelman-Kempthorne construction needs ncol <= 2(q^n-1)(q-1) -1. Can't have ncol = " << ncol << " with n=" << akn << " and q = " << q << "\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } return SUCCESS_CHECK; } /* Implement Addelman and Kempthorne's 1961 A.M.S. method with n=3 */ int addelkempn(GF & gf, int akn, bclib::matrix & A, int ncol) { int p, q; int kay; /* A&K notation */ int col, square, ksquare; int monic, elt; size_t numin; size_t aknu = static_cast (akn); p = gf.p; q = gf.q; int test = addelkempncheck(q, p, akn, ncol); if (test != SUCCESS_CHECK) { return FAILURE_CHECK; } std::vector b(q); std::vector c(q); std::vector k(q); std::vector x(aknu); std::vector s(aknu); std::vector coef(aknu); std::vector indx(aknu); for (size_t i = 0; i < aknu; i++) { x[i] = 0; } for (size_t row = 0; row < static_cast(primes::ipow(q, akn)); row++) { /* First q^akn rows */ col = 0; s[0] = 1; for (size_t i = 1; i < aknu; i++) /* first subset */ { s[i] = 0; /* nonempty subsets of x indices */ } for (size_t sub = 1; sub < static_cast(primes::ipow(2, akn)) && col < ncol; sub++) { monic = -1; numin = 0; for (size_t i = 0; i < aknu; i++) { if (s[i]) { if (monic == -1) { monic = static_cast(i); } // TODO: this might be an else on the if(s[i]) /*else { indx[numin++] = i; }*/ } else { indx[numin++] = static_cast(i); } } for (size_t i = 0; i < numin; i++) { coef[i] = 1; } for (size_t poly = 0; poly < static_cast(primes::ipow(q - 1, static_cast(numin))) && col < ncol; poly++) { elt = x[monic]; for (size_t i = 0; i < numin; i++) { elt = gf.plus(elt, gf.times(coef[i],x[indx[i]])); } A(row,col++) = elt; for (int i = static_cast(numin) - 1; i >= 0; i--) // has to be an int to decrement { size_t ui = static_cast(i); coef[ui] = (coef[ui] + 1) % q; if (coef[ui]) { break; } else { coef[ui] = 1; } } } for (size_t i = 0; i < aknu; i++) { s[i] = (s[i] + 1) % 2; if (s[i]) { break; } } } square = gf.times(x[0], x[0]); s[1] = 1; for (size_t i = 2; i < aknu; i++) /* first subset */ { s[i] = 0; /* nonempty subsets of x indices */ } for (size_t sub = 1; sub < static_cast(primes::ipow(2, akn - 1)) && col < ncol; sub++) { monic = -1; numin = 0; for (size_t i = 1; i < aknu; i++) { if (s[i]) { if (monic == -1) { monic = static_cast(i); } // this might be an else on the if(s[i]) /*else { indx[numin++] = i; }*/ } else { indx[numin++] = static_cast(i); } } coef[0] = 0; for (size_t i = 1; i < numin + 1; i++) { coef[i] = 1; } int polymax = q * primes::ipow(q - 1, static_cast(numin)); for (size_t poly = 0; poly < static_cast(polymax) && col < ncol; poly++) { elt = gf.plus(square,gf.times(x[0],coef[0])); elt = gf.plus(elt,x[monic]); for (size_t i = 1; i < numin + 1; i++) { elt = gf.plus(elt,gf.times(coef[i],x[indx[i - 1]])); } A(row,col++) = elt; for (int i = static_cast(numin) + 1 - 1; i >= 0; i--) // has to be an int { size_t ui = static_cast(i); coef[ui] = (coef[ui] + 1) % q; if (coef[ui]) { break; } else { if (i > 0) { coef[ui] = 1; } } } } for (size_t i = 1; i < aknu; i++) { s[i] = (s[i] + 1) % 2; if (s[i]) { break; } } } for (int i = akn - 1; i >= 0; i--) // has to be an int to decrement { size_t ui = static_cast(i); x[ui] = (x[ui] + 1) % q; if (x[ui]) { break; } } } if (p != 2) /* Constants kay,b,c,k for odd p */ { akodd(gf, &kay, b, c, k); } else /* Constants kay,b,c,k for even p */ { akeven(gf, &kay, b, c, k); } for (size_t i = 0; i < aknu; i++) { x[i] = 0; } int rowmax = 2 * primes::ipow(q, akn); for (size_t row = static_cast(primes::ipow(q, akn)); row < static_cast(rowmax); row++) /* Second q^akn rows */ { col = 0; s[0] = 1; for (size_t i = 1; i < aknu; i++) /* first subset */ { s[i] = 0; /* nonempty subsets of x indices */ } for (size_t sub = 1; sub < static_cast(primes::ipow(2, akn)) && col < ncol; sub++) { monic = -1; numin = 0; for (size_t i = 0; i < aknu; i++) { if (s[i]) { if (monic == -1) { monic = static_cast(i); } // this might be an else on the if(s[i]) /*else { indx[numin++] = i; }*/ } else { indx[numin++] = static_cast(i); } } for (size_t i = 0; i < numin; i++) { coef[i] = 1; } for (size_t poly = 0; poly < static_cast(primes::ipow(q - 1, static_cast(numin))) && col < ncol; poly++) { elt = x[monic]; if (numin && s[0]) { elt = gf.plus(elt,b[coef[0]]); } for (size_t i = 0; i < numin; i++) { elt = gf.plus(elt,gf.times(coef[i],x[indx[i]])); } A(row,col++) = elt; for (int i = static_cast(numin) - 1; i >= 0; i--) // has to be an int to decrement { size_t ui = static_cast(i); coef[ui] = (coef[ui] + 1) % q; if (coef[ui]) { break; } else { coef[ui] = 1; } } } for (size_t i = 0; i < aknu; i++) { s[i] = (s[i] + 1) % 2; if (s[i]) { break; } } } ksquare = gf.times(kay,gf.times(x[0],x[0])); s[1] = 1; for (size_t i = 2; i < aknu; i++) /* first subset */ { s[i] = 0; /* nonempty subsets of x indices */ } for (size_t sub = 1; sub < static_cast(primes::ipow(2, akn - 1)) && col < ncol; sub++) { monic = -1; numin = 0; for (size_t i = 1; i < aknu; i++) { if (s[i]) { if (monic == -1) { monic = static_cast(i); } // this might be an else on the if(s[i]) /*else { indx[numin++] = i; }*/ } else { indx[numin++] = static_cast(i); } } coef[0] = 0; for (size_t i = 1; i < numin + 1; i++) { coef[i] = 1; } int polymax = q * primes::ipow(q - 1, static_cast(numin)); for (size_t poly = 0; poly < static_cast(polymax) && col < ncol; poly++) { elt = gf.plus(ksquare,gf.times(x[0],k[coef[0]])); elt = gf.plus(elt,x[monic]); elt = gf.plus(elt,c[coef[0]]); for (size_t i = 1; i < numin + 1; i++) { elt = gf.plus(elt,gf.times(coef[i],x[indx[i - 1]])); } A(row,col++) = elt; for (int i = static_cast(numin) + 1 - 1; i >= 0; i--) // has to be an int to decrement // don't understand + 1 - 1 { size_t ui = static_cast(i); coef[ui] = (coef[ui] + 1) % q; if (coef[ui]) { break; } else { coef[ui] = i > 0 ? 1 : 0; } } } for (size_t i = 1; i < aknu; i++) { s[i] = (s[i] + 1) % 2; if (s[i]) { break; } } } for (int i = static_cast(aknu) - 1; i >= 0; i--) // has to be an int to decrement { size_t ui = static_cast(i); x[ui] = (x[ui] + 1) % q; if (x[ui]) { break; } } } return SUCCESS_CHECK; } // LCOV_EXCL_STOP } // end namespace } // end namespace lhs/src/galois.cpp0000644000176200001440000002207513425401602013614 0ustar liggesusers/** * @file galois.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "galois.h" /* Manipulation of generic Galois fields. See gfields.c for construction of specific Galois fields. */ namespace oacpp { namespace galoisfield { // TODO: I am copying the entire object here, there may be a better way to do with with // a row or column iterator in the matrix object since these are read only on p1 and p2 // TODO: evaluate const for functions better void GF_poly_sum(int p, int n, std::vector p1, std::vector p2, std::vector & sum) { for (size_t i = 0; i < static_cast(n); i++) { sum[i] = (p1[i] + p2[i]) % p; } } void GF_poly_prod(int p, int n, std::vector & xton, std::vector p1, std::vector p2, std::vector & prod) /* Set prod = p1*p2 with coefficients modulo p, and x^n replaced by polynomial xton. TODO: I am copying the entire object here, there may be a better way to do with with a row or column iterator in the matrix object since these are read only on p1 and p2 */ { size_t nu = static_cast(n); std::vector longprod(2*nu-1); longprod.assign(2*nu-1, 0); for (size_t i = 0; i < nu; i++) { for (size_t j = 0; j < nu; j++) { longprod[i + j] += p1[i] * p2[j]; } } for (int i = 2 * n - 2; i > n - 1; i--) // has to be an int to decrement less than zero { size_t ui = static_cast(i); for (size_t j = 0; j < nu; j++) { longprod[ui - nu + j] += xton[j] * longprod[ui]; } } for (size_t i = 0; i < nu; i++) { prod[i] = longprod[i] % p; } } int GF_poly2int(int p, int n, std::vector & poly) { int ans = 0; for (int i = n - 1; i > 0; i--) // has to be an int to decrement less than zero { size_t ui = static_cast(i); ans = (ans + poly[ui]) * p; } ans += poly[0]; return ans; } /* Make ready the Galois Field */ int GF_ready(GF & gf, int p, int n, std::vector & xton) { size_t q; std::ostringstream msg; std::vector poly(n); gf.n = n; gf.p = p; q = 1; for (int i = 0; i < n; i++) { q *= p; } gf.q = static_cast(q); gf.xton = std::vector(n); for (size_t i = 0; i < static_cast(n); i++) { gf.xton[i] = xton[i]; } gf.plus = bclib::matrix(q,q); gf.times = bclib::matrix(q,q); gf.inv = std::vector(q); gf.neg = std::vector(q); gf.root = std::vector(q); gf.poly = bclib::matrix(q, n); for (size_t i = 0; i < static_cast(n); i++) { gf.poly(0,i) = 0; } for (size_t i = 1; i < q; i++) { size_t click; for (click = 0; gf.poly(i - 1,click) == (p - 1); click++) { gf.poly(i,click) = 0; } gf.poly(i,click) = gf.poly(i - 1,click) + 1; for (size_t j = click + 1; j < static_cast(n); j++) { gf.poly(i,j) = gf.poly(i - 1,j); } } for (size_t i = 0; i < q; i++) { for (size_t j = 0; j < q; j++) { //GF_poly_sum(p, n, gf.poly[i], gf.poly[j], poly); GF_poly_sum(p, n, gf.poly.getrow(i), gf.poly.getrow(j), poly); gf.plus(i,j) = GF_poly2int(p, n, poly); GF_poly_prod(p, n, xton, gf.poly.getrow(i), gf.poly.getrow(j), poly); gf.times(i,j) = GF_poly2int(p, n, poly); } } for (size_t i = 0; i < q; i++) { gf.inv[i] = -1; for (size_t j = 0; j < q; j++) { if (gf.times(i,j) == 1) { gf.inv[i] = static_cast(j); } } if (i > 0 && gf.inv[i] <= 0) { // LCOV_EXCL_START msg << "There is something wrong with the Galois field\n"; msg << "used for q=" << q << ". Element " << i << "has no reciprocal.\n"; const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } // LCOV_EXCL_STOP } for (size_t i = 0; i < q; i++) { gf.neg[i] = -1; for (size_t j = 0; j < q; j++) if (gf.plus(i,j) == 0) gf.neg[i] = static_cast(j); if (i > 0 && gf.neg[i] <= 0) { // LCOV_EXCL_START msg << "There is something wrong with the Galois field\n"; msg << "used for q=" << q << ". Element " << i << " has no negative.\n"; throw std::runtime_error(msg.str().c_str()); } // LCOV_EXCL_STOP } for (size_t i = 0; i < q; i++) { gf.root[i] = -1; for (size_t j = 0; j < q; j++) { if (gf.times(j,j) == static_cast(i)) { gf.root[i] = static_cast(j); } } } return 1; } void GF_print(GF & gf) // LCOV_EXCL_START { int n, p, q; n = gf.n; p = gf.p; q = gf.q; if (q > 999) { PRINT_OUTPUT << "Warning q=" << q << " will overflow print field.\n"; } PRINT_OUTPUT << "\nFor GF(" << q << ") p=" << p << " n=" << n << "\n"; PRINT_OUTPUT << "x**n = ("; for (int i = 0; i < n - 1; i++) { PRINT_OUTPUT << gf.xton[i] << ","; } PRINT_OUTPUT << gf.xton[static_cast(n) - 1] << ")\n"; PRINT_OUTPUT << "\n\nGF(" << q << ") Polynomial coefficients:\n"; for (int i = 0; i < q; i++) { PRINT_OUTPUT << " " << i << " "; for (int j = 0; j < n; j++) { PRINT_OUTPUT << gf.poly(i,j) << " "; } PRINT_OUTPUT << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Addition Table\n"; for (int i = 0; i < q; i++) { PRINT_OUTPUT << " "; for (int j = 0; j < q; j++) { PRINT_OUTPUT << " " << gf.plus(i,j); } PRINT_OUTPUT << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Multiplication table\n"; for (int i = 0; i < q; i++) { PRINT_OUTPUT << " "; for (int j = 0; j < q; j++) { PRINT_OUTPUT << " " << gf.times(i,j); } PRINT_OUTPUT << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Reciprocals\n"; for (int i = 1; i < q; i++) { PRINT_OUTPUT << " " << i << " " << gf.inv[i] << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Negatives\n"; for (int i = 0; i < q; i++) { PRINT_OUTPUT << " " << i << " " << gf.neg[i] << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Square roots\n"; for (int i = 0; i < q; i++) { PRINT_OUTPUT << " " << i << " " << gf.root[i] << "\n"; } } // LCOV_EXCL_STOP } // end namespace } // end namespace lhs/src/ak3.cpp0000644000176200001440000002460213425401602013012 0ustar liggesusers/** * @file ak3.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "ak.h" namespace oacpp { namespace oaaddelkemp { int addelkemp3check(int q, int p, int ncol) { std::string msg; if (p == 2 && q > 4) { msg = "This Addelman-Kempthorne OA(2q^3,ncol,q,2) is only \n available for odd prime powers q and for even prime \n powers q<=4.\n"; throw std::runtime_error(msg.c_str()); } if (q == 8) { /* Moot */ msg = "This Addelman-Kempthorne OA(2*8^3,ncol,8,2) is experimental and not yet working."; throw std::runtime_error(msg.c_str()); } if (ncol > 2 * q * q + 2 * q + 1) { std::ostringstream s; s << "The Addelman-Kempthorne (n=3) construction needs ncol <= 2q^2+2q+1. Can't have ncol = " << ncol << " with q = " << q << "\n"; const std::string ss = s.str(); throw std::runtime_error(ss.c_str()); } return SUCCESS_CHECK; } /* Implement Addelman and Kempthorne's 1961 A.M.S. method with n=3 */ int addelkemp3(GF & gf, bclib::matrix & A, int ncol) { int kay; //std::vector b, c, k; /* A&K notation */ int square, ksquare; size_t row, col; int p = gf.p; size_t q = static_cast(gf.q); // Throws on any error addelkemp3check(static_cast(q), p, ncol); std::vector b(q); std::vector c(q); std::vector k(q); for (size_t i1 = 0; i1 < q; i1++) { /* First q^3 rows */ square = gf.times(i1,i1); for (size_t i2 = 0; i2 < q; i2++) { for (size_t i3 = 0; i3 < static_cast(q); i3++) { row = i3 + q * i2 + q * q * i1; col = 0; if (col < static_cast(ncol)) { A(row, col++) = static_cast(i2); /* y */ } for (size_t m1 = 1; m1 < q && col < static_cast(ncol); m1++) /* x + my */ { A(row,col++) = gf.plus(i1,gf.times(m1,i2)); } if (col < static_cast(ncol)) { A(row, col++) = static_cast(i3); /* z */ } for (size_t m2 = 1; m2 < q && col < static_cast(ncol); m2++) /* x + mz */ { A(row,col++) = gf.plus(i1,gf.times(m2,i3)); } for (size_t m2 = 1; m2 < q && col < static_cast(ncol); m2++) /* y + mz */ { A(row,col++) = gf.plus(i2,gf.times(m2,i3)); } for (size_t m1 = 1; m1 < q && col < static_cast(ncol); m1++) /* x + my + nz */ { for (size_t m2 = 1; m2 < q && col < static_cast(ncol); m2++) { A(row,col++) = gf.plus(i1,gf.plus(gf.times(m1,i2),gf.times(m2,i3))); } } for (size_t m1 = 0; m1 < q && col < static_cast(ncol); m1++) /* x^2 + mx + y */ { A(row,col++) = gf.plus(square, gf.plus(i2, gf.times(m1,i1))); } for (size_t m1 = 0; m1 < q && col < static_cast(ncol); m1++) /* x^2 + mx + z */ { A(row,col++) = gf.plus(square, gf.plus(i3, gf.times(m1,i1))); } for (size_t m1 = 0; m1 < q && col < static_cast(ncol); m1++) /* x^2 + mx + y + nz */ { for (size_t m2 = 1; m2 < q && col < static_cast(ncol); m2++) { A(row,col++) = gf.plus(square, gf.plus(i2, gf.plus( gf.times(m2,i3) , gf.times(m1,i1) ) ) ); } } if (col < static_cast(ncol)) { A(row, col++) = static_cast(i1); /* x */ } } } } if (p != 2) { akodd(gf, &kay, b, c, k); /* Get kay,b,c,k for odd p */ } else { akeven(gf, &kay, b, c, k); /* Constants kay,b,c,k for even p */ } for (size_t i1 = 0; i1 < q; i1++) { /* Second q^3 rows */ square = gf.times(i1,i1); ksquare = gf.times(kay,square); for (size_t i2 = 0; i2 < q; i2++) { for (size_t i3 = 0; i3 < q; i3++) { row = i3 + q * i2 + q * q * i1 + q * q*q; col = 0; if (col < static_cast(ncol)) { A(row, col++) = static_cast(i2); /* y */ } for (size_t m1 = 1; m1 < q && col < static_cast(ncol); m1++) { /* x + my + b(m) */ A(row,col) = gf.plus(i1,gf.times(m1,i2)); A(row,col) = gf.plus(A(row,col),b[m1]); col++; } if (col < static_cast(ncol)) { A(row,col++) = static_cast(i3); /* z */ } for (size_t m2 = 1; m2 < q && col < static_cast(ncol); m2++) { /* x + mz + b(m) */ A(row,col) = gf.plus(i1,gf.times(m2,i3)); A(row,col) = gf.plus(A(row,col),b[m2]); col++; } for (size_t m2 = 1; m2 < q && col < static_cast(ncol); m2++) /* y + mz */ { A(row,col++) = gf.plus(i2,gf.times(m2,i3)); } for (size_t m1 = 1; m1 < q && col < static_cast(ncol); m1++) /* x + my + nz + b(m) */ { for (size_t m2 = 1; m2 < q && col < static_cast(ncol); m2++) { A(row,col) = gf.plus(i1,gf.plus(gf.times(m1,i2),gf.times(m2,i3))); A(row,col) = gf.plus(A(row,col),b[m1]); col++; } } for (size_t m1 = 0; m1 < q && col < static_cast(ncol); m1++) { /* kx^2 + k(m)x + y + c(m)*/ A(row,col) = gf.plus(ksquare, gf.plus(i2, gf.times(k[m1],i1))); A(row,col) = gf.plus(A(row,col),c[m1]); col++; } for (size_t m1 = 0; m1 < q && col < static_cast(ncol); m1++) { /* kx^2 + k(m)x + z + c(m)*/ A(row,col) = gf.plus(ksquare, gf.plus(i3, gf.times(k[m1],i1))); A(row,col) = gf.plus(A(row,col),c[m1]); col++; } for (size_t m1 = 0; m1 < q && col < static_cast(ncol); m1++) /* kx^2 + k(m)x + y + nz +c(m) */ { for (size_t m2 = 1; m2 < q && col < static_cast(ncol); m2++) { A(row,col) = gf.plus(ksquare, gf.plus(i2, gf.plus( gf.times(m2,i3) , gf.times(k[m1],i1) ) ) ); A(row,col) = gf.plus( A(row,col) , c[m1] ); col++; } } if (col < static_cast(ncol)) { A(row, col++) = static_cast(i1); /* x */ } } } } return 1; } } // end namespace } // end namespace lhs/src/oa.cpp0000644000176200001440000005254213425401602012737 0ustar liggesusers/** * @file oa.cpp * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * License: This file may be freely used and shared according to the original license. * * Reference: * * * Original Header: *
* These programs construct and manipulate orthogonal arrays. They were prepared by * * - Art Owen * - Department of Statistics * - Sequoia Hall * - Stanford CA 94305 * * They may be freely used and shared. This code comes * with no warranty of any kind. Use it at your own * risk. * * I thank the Semiconductor Research Corporation and * the National Science Foundation for supporting this * work. *
*/ #include "oa.h" #include "matrix.h" namespace oacpp { namespace oastrength { void OA_strworkcheck(double work, int str) { if (work > BIGWORK) // LCOV_EXCL_START { PRINT_OUTPUT << "If the array has strength " << str << ", " << work << " comparisons will\n"; PRINT_OUTPUT << "be required to prove it. This might take a long time.\n"; PRINT_OUTPUT << "This warning is triggered when more than " << BIGWORK << " comparisons\n"; PRINT_OUTPUT << "are required. To avoid this warning increase BIGWORK in\n"; PRINT_OUTPUT << "oa.h. Intermediate results will be printed.\n\n"; } else if (work > MEDWORK) { PRINT_OUTPUT << "Since more than " << MEDWORK << " comparisons may be required to\n"; PRINT_OUTPUT << "to check whether the array has strength " << str << ", intermediate\n"; PRINT_OUTPUT << "results will be printed. To avoid this warning increase\n"; PRINT_OUTPUT << "MEDWORK in oa.h\n\n"; } // LCOV_EXCL_STOP } void OA_strength(int q, bclib::matrix & A, int* str, int verbose) { *str = -1; int test = OA_str0(q, A, verbose); if (test == SUCCESS_CHECK) { *str = 0; } else { return; } test = OA_str1(q, A, verbose); if (test == SUCCESS_CHECK) { *str = 1; } else { return; } test = OA_strt(q, A, *str + 1, verbose); while (test == SUCCESS_CHECK) { (*str)++; test = OA_strt(q, A, *str + 1, verbose); } return; } int OA_str0(int q, bclib::matrix & A, int verbose) { size_t nrow = A.rowsize(); size_t ncol = A.colsize(); for (size_t j1 = 0; j1 < ncol; j1++) { for (size_t i = 0; i < nrow; i++) { if (A(i,j1) < 0 || A(i,j1) >= q) { if (verbose >= 2) // LCOV_EXCL_START { PRINT_OUTPUT << "Array is not even of strength 0, that is there are elements\n"; PRINT_OUTPUT << "other than integers 0 through " << q << " inclusive in it.\n"; PRINT_OUTPUT << "The first exception is A[" << i << "," << j1 << "] = " << A(i, j1) << ".\n"; } // LCOV_EXCL_STOP return 0; } } } if (verbose >= 2) { PRINT_OUTPUT << "The array has strength (at least) 0.\n"; // LCOV_EXCL_LINE } return SUCCESS_CHECK; } int OA_str1(int q, bclib::matrix & A, int verbose) { size_t nrow = A.rowsize(); size_t ncol = A.colsize(); int lambda, count; double work; if (static_cast(nrow) % q != 0) { if (verbose >= 2) // LCOV_EXCL_START { PRINT_OUTPUT << "The array cannot have strength 1, because the number\n"; PRINT_OUTPUT << "of rows " << nrow << " is not a multiple of q = " << q << ".\n"; } // LCOV_EXCL_STOP return 0; } lambda = static_cast(nrow) / q; work = static_cast(nrow) * static_cast(ncol) * static_cast(q); OA_strworkcheck(work, 1); for (size_t j1 = 0; j1 < ncol; j1++) { for (int q1 = 0; q1 < q; q1++) { count = 0; for (size_t i = 0; i < nrow; i++) { count += (A(i,j1) == q1); } if (count != lambda) { if (verbose >= 2) // LCOV_EXCL_START { PRINT_OUTPUT << "Array is not of strength 1. The first violation arises for\n"; PRINT_OUTPUT << "the number of times A[," << j1 << "] = " << q1 << ".\n"; PRINT_OUTPUT << "This happened in " << count << " rows, it should have happened in " << lambda << " rows.\n"; } // LCOV_EXCL_STOP return 0; } } if (work > MEDWORK && verbose > 0) { PRINT_OUTPUT << "No violation of strength 1 involves column " << j1 << ".\n"; // LCOV_EXCL_LINE } } if (verbose >= 2) { PRINT_OUTPUT << "The array has strength (at least) 1.\n"; // LCOV_EXCL_LINE } return SUCCESS_CHECK; } int OA_str2(int q, bclib::matrix & A, int verbose) { size_t nrow = A.rowsize(); size_t ncol = A.colsize(); int q1, q2; int lambda, count; double work; if (ncol < 2) { if (verbose > 0) // LCOV_EXCL_START { PRINT_OUTPUT << "Array has only " << ncol << " column(s). At least two\n"; PRINT_OUTPUT << "columns are necessary for strength 2 to make sense.\n"; } // LCOV_EXCL_STOP return 0; } if (static_cast(nrow) % (q * q)) { if (verbose > 0) // LCOV_EXCL_START { PRINT_OUTPUT << "The array cannot have strength 2, because the number\n"; PRINT_OUTPUT << "of rows " << nrow << " is not a multiple of q^2 = " << q << "^2 = " << q*q << ".\n"; } // LCOV_EXCL_STOP return 0; } lambda = static_cast(nrow) / (q * q); work = static_cast(nrow * ncol) * static_cast((ncol - 1.0) * q * q) / 2.0; OA_strworkcheck(work, 2); for (size_t j1 = 0; j1 < ncol; j1++) { for (size_t j2 = j1 + 1; j2 < ncol; j2++) { for (q1 = 0; q1 < q; q1++) { for (q2 = 0; q2 < q; q2++) { count = 0; for (size_t i = 0; i < nrow; i++) { count += (A(i,j1) == q1) && (A(i,j2) == q2); } if (count != lambda) { if (verbose >= 2) // LCOV_EXCL_START { PRINT_OUTPUT << "Array is not of strength 2. The first violation arises for\n"; PRINT_OUTPUT << "the number of times (A[," << j1 << "],A[," << j2 << "]) = (" << q1 << "," << q2 << ").\n"; PRINT_OUTPUT << "This happened in " << count << " rows, it should have happened in " << lambda << " rows.\n"; } // LCOV_EXCL_STOP return 0; } } } } if (work > MEDWORK && verbose > 0) { PRINT_OUTPUT << "No violation of strength 2 involves column " << j1 << ".\n"; // LCOV_EXCL_LINE } } if (verbose >= 2) { PRINT_OUTPUT << "The array has strength (at least) 2.\n"; // LCOV_EXCL_LINE } return 1; } int OA_str3(int q, bclib::matrix & A, int verbose) { size_t nrow = A.rowsize(); size_t ncol = A.colsize(); int q1, q2, q3; int lambda, count; double work; if (ncol < 3) { if (verbose > 0) // LCOV_EXCL_START { PRINT_OUTPUT << "Array has only " << ncol << " column(s). At least three\n"; PRINT_OUTPUT << "columns are necessary for strength 3 to make sense.\n"; } // LCOV_EXCL_STOP return 0; } if (static_cast(nrow) % (q * q * q)) { if (verbose > 0) // LCOV_EXCL_START { PRINT_OUTPUT << "The array cannot have strength 3, because the number\n"; PRINT_OUTPUT << "of rows " << nrow << " is not a multiple of q^3 = " << q << "^3 = " << q*q*q << ".\n"; } // LCOV_EXCL_STOP return 0; } lambda = static_cast(nrow) / (q * q * q); work = static_cast(nrow * ncol) * static_cast((ncol - 1.0)*(ncol - 2.0) * q * q * q) / 6.0; OA_strworkcheck(work, 3); for (size_t j1 = 0; j1 < ncol; j1++) { for (size_t j2 = j1 + 1; j2 < ncol; j2++) { for (size_t j3 = j2 + 1; j3 < ncol; j3++) { for (q1 = 0; q1 < q; q1++) { for (q2 = 0; q2 < q; q2++) { for (q3 = 0; q3 < q; q3++) { count = 0; for (size_t i = 0; i < nrow; i++) { count += (A(i,j1) == q1) && (A(i,j2) == q2) && (A(i,j3) == q3); } if (count != lambda) { if (verbose >= 2) // LCOV_EXCL_START { PRINT_OUTPUT << "Array is not of strength 3. The first violation arises for\n"; PRINT_OUTPUT << "the number of times (A[," << j1 << "],A[," << j2 << "],A[," << j3 << "]) = (" << q1 << "," << q2 << "," << q3 << ").\n"; PRINT_OUTPUT << "This happened in " << count << " rows, it should have happened in " << lambda << " rows.\n"; } // LCOV_EXCL_STOP return 0; } } } } } } if (work > MEDWORK && verbose > 0) { PRINT_OUTPUT << "No violation of strength 3 involves column " << j1 << ".\n"; // LCOV_EXCL_LINE } } if (verbose >= 2) { PRINT_OUTPUT << "The array has strength (at least) 3.\n"; // LCOV_EXCL_LINE } return 1; } int OA_str4(int q, bclib::matrix & A, int verbose) { size_t nrow = A.rowsize(); size_t ncol = A.colsize(); int q1, q2, q3, q4; int lambda, count; double work; if (ncol < 4) { if (verbose > 0) // LCOV_EXCL_START { PRINT_OUTPUT << "Array has only " << ncol << " column(s). At least four\n"; PRINT_OUTPUT << "columns are necessary for strength 4 to make sense.\n"; } // LCOV_EXCL_STOP return 0; } if (static_cast(nrow) % (q * q * q * q)) { if (verbose > 0) // LCOV_EXCL_START { PRINT_OUTPUT << "The array cannot have strength 4, because the number\n"; PRINT_OUTPUT << "of rows " << nrow << " is not a multiple of q^4 = " << q << "^4 = " << q*q*q*q << ".\n"; } // LCOV_EXCL_STOP return 0; } lambda = static_cast(nrow) / (q * q * q * q); // cast to doubles to prevent overflow double dnrow = static_cast(nrow); double dncol = static_cast(ncol); double dq = static_cast(q); work = dnrow * dncol * (dncol - 1.0) * (dncol - 2.0) * (dncol - 3.0) * dq * dq * dq * dq / 24.0; OA_strworkcheck(work, 4); for (size_t j1 = 0; j1 < ncol; j1++) { for (size_t j2 = j1 + 1; j2 < ncol; j2++) { for (size_t j3 = j2 + 1; j3 < ncol; j3++) { for (size_t j4 = j3 + 1; j4 < ncol; j4++) { for (q1 = 0; q1 < q; q1++) { for (q2 = 0; q2 < q; q2++) { for (q3 = 0; q3 < q; q3++) { for (q4 = 0; q4 < q; q4++) { count = 0; for (size_t i = 0; i < nrow; i++) { count += (A(i,j1) == q1) && (A(i,j2) == q2) && (A(i,j3) == q3) && (A(i,j4) == q4); } if (count != lambda) { if (verbose >= 2) // LCOV_EXCL_START { PRINT_OUTPUT << "Array is not of strength 4. The first violation arises for\n"; PRINT_OUTPUT << "the number of times (A[," << j1 << "],A[," << j2 << "],A[," << j3 << "],A[," << j4 << "]) = (" << q1 << "," << q2 << "," << q3 << "," << q4 << ").\n"; PRINT_OUTPUT << "This happened in " << count << " rows, it should have happened in " << lambda << " rows.\n"; } // LCOV_EXCL_STOP return 0; } } } } } } } } if (work > MEDWORK && verbose > 0) { PRINT_OUTPUT << "No violation of strength 4 involves column " << j1 << ".\n"; // LCOV_EXCL_LINE } } if (verbose >= 2) { PRINT_OUTPUT << "The array has strength (at least) 4.\n"; // LCOV_EXCL_LINE } return 1; } int OA_strt(int q, bclib::matrix & A, int t, int verbose) { size_t nrow = A.rowsize(); size_t ncol = A.colsize(); int ctuples, qtuples; int lambda, count, match; double work; std::vector clist, qlist; if (t < 0) { if (verbose > 0) // LCOV_EXCL_START { PRINT_OUTPUT << "Don't know how to verify strength " << t << ". It doesn't\n"; PRINT_OUTPUT << "make sense.\n"; } // LCOV_EXCL_STOP return 0; } if (ncol < static_cast(t)) { if (verbose > 0) // LCOV_EXCL_START { PRINT_OUTPUT << "Array has only " << ncol << " column(s). At least " << t << "\n"; PRINT_OUTPUT << "columns are necessary for strength " << t << " to make sense.\n"; } // LCOV_EXCL_STOP return 0; } if (t == 0) { return OA_str0(q, A, verbose); } if (nrow % primes::ipow(q, t)) { if (verbose > 0) // LCOV_EXCL_START { PRINT_OUTPUT << "The array cannot have strength " << t << ", because the number\n"; PRINT_OUTPUT << "of rows " << nrow << " is not a multiple of q^" << t << " = " << q << "^" << t << " = " << primes::ipow(q, t) << ".\n"; } // LCOV_EXCL_STOP return 0; } lambda = static_cast(nrow) / primes::ipow(q, t); work = static_cast(nrow * primes::ipow(q, t)); ctuples = 1; clist = std::vector(t); qlist = std::vector(t); for (int i = 0; i < t; i++) { work *= static_cast((ncol - i)) / static_cast((i + 1.0)); ctuples *= static_cast(ncol) - i; qlist[i] = 0; clist[i] = i; } for (int i = 0; i < t; i++) { ctuples /= (i + 1); } qtuples = primes::ipow(q, t); OA_strworkcheck(work, t); for (int ic = 0; ic < ctuples; ic++) /* Loop over ordered tuples of columns */ { for (int iq = 0; iq < qtuples; iq++) /* Loop over unordered tuples of symbols */ { count = 0; for (size_t row = 0; row < nrow; row++) { match = 1; for (int i = 0; i < t && match; i++) { match *= A(row,clist[i]) == qlist[i]; } count += match; } if (count != lambda) { if (verbose >= 2) // LCOV_EXCL_START { PRINT_OUTPUT << "Array is not of strength " << t << ". The first violation arises for\n"; PRINT_OUTPUT << "the number of times ("; for (int i = 0; i < t; i++) { PRINT_OUTPUT << "A(," << clist[i] << ")" << ((i == t - 1) ? ")" : ","); } PRINT_OUTPUT << " = ("; for (int i = 0; i < t; i++) { PRINT_OUTPUT << qlist[i] << ((i == t - 1) ? ").\n" : ","); } PRINT_OUTPUT << "This happened in " << count << " rows, it should have happened in " << lambda << " rows.\n"; } // LCOV_EXCL_STOP return 0; } for (int i = t - 1; i >= 0; i--) // has to be int { qlist[i] = (qlist[i] + 1) % q; if (qlist[i]) { break; } } } for (int i = t - 1; i >= 0; i--) // has to be int { clist[i] = (clist[i] + 1) % (static_cast(ncol) + i - t + 1); if (clist[i]) { break; } } if (work > MEDWORK && verbose > 0 && ((t == 1 || t > 1) && (clist[1] == 0))) { PRINT_OUTPUT << "No violation of strength " << t << " involves column " << (clist[0] + static_cast(ncol) - 1) % static_cast(ncol) << ".\n"; // LCOV_EXCL_LINE } for (size_t i = 1; i < static_cast(t); i++) { if (clist[i] <= clist[i - 1]) { clist[i] = clist[i - 1] + 1; } } } if (verbose >= 2) { PRINT_OUTPUT << "The array has strength (at least) " << t << ".\n"; // LCOV_EXCL_LINE } return SUCCESS_CHECK; } } // end namespace }// end namespace lhs/src/COrthogonalArray.h0000644000176200001440000006206513425401602015224 0ustar liggesusers/** * @file COrthogonalArray.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . * * Reference: * */ #ifndef CORTHOGONALARRAY_H #define CORTHOGONALARRAY_H #include "OACommonDefines.h" #include "galdef.h" #include "galois.h" #include "construct.h" #include "runif.h" #include "rutils.h" #include "oa.h" #include "primes.h" /** The number of rows of the oa to check and print */ #define ROWCHECK 50 /** no debug messages */ #define NOMESSAGES 0 /** some debug messages */ #define SOMEMESSAGES 1 /** all debug messages should be shown */ #define ALLMESSAGES 2 /** * Orthogonal Array Namespace */ namespace oacpp { /** * Orthogonal Array Class * * A collection of functions used as an API for Art Owen's oa library. */ class COrthogonalArray { public: /** * Default Constructor */ COrthogonalArray(); /** * Default Destructor */ ~COrthogonalArray(){}; /** * Construct an orthogonal array using the Addelman Kempthorne algorithm * * From the original documentation: *
* The addelkemp program produces OA( 2q^2, k, q, 2 ), k <= 2q+1, * for odd prime powers q. Even prime powers may be produced using * bosebush above. This construction is based on: * * S. Addelman and O. Kempthorne (1961) Annals of Mathematical Statistics, * Vol 32 pp 1167-1176. * * using n=2 in their notation. * * 2q columns can be * constructed without a coincidence defect. Setting k=2q+1 * leads to an array with the coincidence defect. Some * triples of columns contain duplicate rows. (The lack of * a coincidence defect has been verified for * q = 2,3,4,5,7,9,11,13,17,19,23,25 and k = 2q.) * * This construction should work for all prime powers * q, but it failed to do so for even powers greater * than 4. This may have been a programming error, or * it may have stemmed from misunderstanding of the description * of the algorithm. The program rejects requests with * q = 2^r for r > 2. The Bose Bush construction handles these * cases. * * The description of the construction for odd prime powers * calls for some arithmetic involving the number 4. In * Galois fields with 3^r elements, there is no 4. Replacing 4 * by 1 for these fields works when q = 3,9,27 (brute force * verification). *
* * @param q the number of symbols (0,...,q-1) * @param k the number of columns in the array. k <= q+1 * @param [out] n the number of rows in the array, n = 2q^2 * @throws std::runtime_error */ void addelkemp(int q, int k, int* n); /** * Construct an orthogonal array using the Addelman Kempthorne algorithm * * From the original documentation: *
* The addelkemp3 program produces OA( 2*q^3, k, q, 2 ), * k <= 2q^2+2q+1, for prime powers q. q * may be an odd prime power, or q may be 2 or 4. * * This construction is based on: * * S. Addelman and O. Kempthorne (1961) Annals of Mathematical Statistics, * Vol 32 pp 1167-1176. * * using n=3 in their notation. * * Coincidences are much harder to understand with these designs. * For example addelkemp3 3 9 does lead to a number of triple * coincidences, that is pairs of rows in which 3 columns agree, * but no quadruple coincidences. addelkemp3 9 28 produces * an extra column that figures in some quadruple coincidences. * * As for addelkemp above, 4 is replaced by 1 in fields that * do not have an element 4. Also powers of 2 larger than 4 * are not allowed, as described above for addelkemp. * * The article is quite vague on this. Page 1173 states * "When n>2 the same procedure will yield the desired plans * if Lemma 5a is used in place of Lemma 5." Page 1175 * provides the example n=3,q=3 which is OA( 54,25,3,2 ). * Based on this example it is possible to make an educated * guess as to how the construction generalizes to n=3. * The resulting OA's are seen, by brute force to be of * strength 2 for q=2,3,4,5,7,11. These OAs are: * - OA( 16, 13, 2, 2 ) * - OA( 54, 25, 3, 2 ) * - OA( 128, 41, 4, 2 ) * - OA( 250, 61, 5, 2 ) * - OA( 686, 113, 7, 2 ) * - OA( 1458, 181, 9, 2 ) * - OA( 2662, 265, 11, 2 ) * * The one with q=7 required 212709392 comparisons to determine * that it really is of strength 2. This took roughly 11.5 minutes * on a DEC 5000/240 workstation (real and elapsed in this case). * The array with q=11 took 1.12671e+10 comparisons to verify its strength. * This took roughly 10 1/2 hours. * * For even q, only q= 2 or 4 are available. The prescription * given in Addelman and Kempthorne (1961) does not appear to work. * Commented out code below attempts to implement that prescription. * It seemed to be impossible to find a constant b[1],c[1] pair. *
* * @param q the number of symbols (0,...,q-1) * @param k the number of columns in the array. k <= 2q^2+2q+1 * @param [out] n the number of rows in the array, n = 2q^3 * @throws std::runtime_error */ void addelkemp3(int q, int k, int* n); /** * Construct an orthogonal array using the Addelman Kempthorne algorithm * * @deprecated This method is not included by default in Art Owens's * project. The method is in the code, but it is not compiled in * the makefile. Adding it as a target to the makefile creates a successful build, * but running addelkempn 3 3 (which should be equivalent to addelkemp3 3) * does not function in the MinGW64 build. * * From the original documentation: *
* The article is quite vague on this. Page 1173 states * "When n>2 the same procedure will yield the desired plans * if Lemma 5a is used in place of Lemma 5." Page 1175 * provides the example n=3,q=3 which is OA( 54,25,3,2 ). * Based on this example it is possible to make an educated * guess as to how the construction generalizes. * * @param akn the exponent on q for the number of rows n = 2q^akn * @param q the number of symbols (0,...,q-1) * @param k the number of columns in the array. k <= 2(q^akn-1)/(q-1) - 1 * @param [out] n the number of rows in the array, n = 2q^akn * @throws std::runtime_error */ void addelkempn(int akn, int q, int k, int* n); /** * Construct an orthogonal array using the Bose algorithm * * From the original documentation: *
* The bose program produces OA( q^2, k, q, 2 ), k <= q+1 * for prime powers q. This is based on: * * R.C. Bose (1938) Sankhya Vol 3 pp 323-338 *
* * @param q the number of symbols (0,...,q-1) * @param k the number of columns in the array. k <= q+1 * @param [out] n the number of rows in the array, n = q^2 * @throws std::runtime_error */ void bose(int q, int k, int* n); /** * Construct an orthogonal array using the Bose-Bush algorithm * * From the original documentation: *
* The bosebush program produces OA( 2q^2, k, q, 2 ), k <= 2q+1, * for powers of 2, q = 2^r. This construction is based on: * * R.C. Bose and K.A. Bush (1952) Annals of Mathematical Statistics, * Vol 23 pp 508-524. * * 2q columns can be constructed without a coincidence defect. Setting * k = 2q+1 leads to an array with the coincidence defect. Some * triples of columns contain duplicate rows. (The lack of * a coincidence defect has been verified for q = 2,4,8,16,32 * and k = 2q.) *
* * @param q the number of symbols (0,...,q-1) * @param k the number of columns in the array. k <= q+1 * @param [out] n the number of rows in the array, n = q^2 * @throws std::runtime_error */ void bosebush(int q, int k, int *n); /** * Construct an orthogonal array using the Bose-Bush algorithm * * From the original documentation: *
* The bosebushl program produces OA( lambda*q^2, k, q, 2 ), * k <= lambda*q+1, for prime powers q and lambda > 1. Both q and * lambda must be powers of the same prime. This construction is based on: * * R.C. Bose and K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 508-524. * * Coincidences are harder to understand with these designs. * For example bosebushl 3 9 does lead to a number of triple * coincidences, that is pairs of rows in which 3 columns agree, * but no quadruple coincidences. bosebush 3 9 28 produces * an extra column that figures in some quadruple coincidences. * * The arrays produced by this program are not always the * largest possible. The article by Bose and Bush cited * above describes ways of adjoining some extra columns. * * When k <= lambda*q, the program produces an array that * is "completely resolvable". What this means is that * the rows of the array may be split into lambda*q consecutive * nonoverlapping sets of rows each of which is OA( q,k,q,1 ). *
* * @param lambda * @param q * @param k * @param n * @throws std::runtime_error */ void bosebushl(int lambda, int q, int k, int* n); /** * Construct an orthogonal array using the Bush algorithm * * From the original documentation: *
* The bush program produces OA( q^3, k, q, 3 ), k <= q+1 * for prime powers q. This strength 3 construction is based on: * * K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 426-434 * * This construction is the most commonly used special case * of busht given below. *
* * @param q the number of symbols (0,...,q-1) * @param k the number of columns in the array. k <= q+1 * @param [out] n the number of rows in the array, n = q^3 * @throws std::runtime_error */ void bush(int q, int k, int* n); /** * Construct an orthogonal array using the Bush algorithm * * From the original documentation: *
* The bush program produces OA( q^t, k, q, t ), k <= q+1, t>=3, * for prime powers q. This strength t construction is based on: * * K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 426-434 *
* * @param str * @param q * @param k * @param n * @throws std::runtime_error */ void busht(int str, int q, int k, int* n); /** * Count the number of columns for which each pair of rows agree * * From the original documentation: *
* This program counts the number of columns in which * each pair of distinct rows agree. * * Input is described above under OA input conventions. *
* * Examples: *
* COrthogonalArray coa; int n; * coa.addelkemp3(3, 25, &n); * coa.oagree(true); *
* * This example finds that in OA( 54, 25, 3, 2 ) * produced by addelkemp3 there exist pairs of rows * agreeing in 9 columns. The first rows to attain * this are rows 0 and 9, the 1st and 10th rows. * *
* COrthogonalArray coa; int n; * coa.addelkemp3(3, 24, &n); * coa.agree(true); *
* * The second example finds that in OA( 54, 24, 3, 2 ) * produced by addelkemp3 there exist pairs of rows * agreeing in 8 columns. No pairs of rows agree in * 9 columns. * * @param verbose Should messages be printed about the findings? * @return the maximum number of agreeing columns */ int oaagree(bool verbose); /** * Count the number of columns for which each three rows agree * * From the original documentation: *
* This program reports on triple coincidences. For all * triples of distinct columns, it counts the number of * distinct pairs of rows in which the triple of columns * agree. * * Input is described above under OA input conventions. * * Examples: * * COrthogonalArray coa; int n; * coa.bosebush(8, 16, &n); * coa.agree(true); * * There are 0 distinct triples of columns that agree * in at least two distinct rows. * * COrthogonalArray coa; int n; * coa.bosebush(8, 17, &n); * coa.agree(true); * * Warning: The Bose-Bush construction with ncol = 2q+1 * has a defect. While it is still an OA(2q^2,2q+1,q,2), * there exist some pairs of rows that agree in three columns. * * There are 8 distinct triples of columns that agree in at least two distinct rows. * * The warning above is generated by bosebush. * The rest shows that there are triple coincidences. * Notice that they all involve the 17th column * (which is column 16, since the first one is column 0). * The other 16 columns can be organized into 8 pairs * with each pair forming a triple with column 16 and * no other triples agreeing in any row. *
* * @param verbose Should messages be printed about the findings? * @return the maximum number of agreeing columns */ int oatriple(bool verbose); /** * Print the dimension of the orthogonal array */ void oadimen(); /** * Randomize an orthogonal array * * From the original documentation *
* This program permutes the symbols in each column. The permutations are * uniformly distributed (all q! permutations have the same * probability) and all columns are permuted independently. * * Input is described above under OA input conventions, * with exceptions noted below to allow passing a random * seed. If oarand is called twice with the same input array, * the same permuted output will result both times, unless * different seeds are given. * * The random number generator is a version of the * Marsaglia-Zaman random number generator, transliterated * into C from FORTRAN. The seed must be four integers * between 1 and 168 inclusive, with not all values equal * to 1. *
* * @param is seed * @param js seed * @param ks seed * @param ls seed */ void oarand(int is, int js, int ks, int ls); /** * Find the strength of an orthogonal array * * This program reads an orthogonal array strength by brute force computation. * In addition to the strength t described above under * the heading orthogonal arrays, strength 0 is taken to * mean that the array indeed has all its elements in the * range 0..q-1. * * An array of strength t \> 0 is also of strength s for * all 0 \<= s \< t. The program starts testing t = 0 and * increases t until it finds t for which the array is * not strength t. * * Finding the strength of an array by brute force is * lightning fast for small arrays but very slow for larger * arrays. When the job is large enough, intermediate * results are printed so the user can decide whether or * not to kill the job, based on how much progress is * being made. * * The function that calculates strength has an argument * verbose. In oastr the array strength function is * called with verbose=2. This prints to standard output * a description of progress as the strength check proceeds. * If one wants to use this function in other settings, * calling it with verbose=1 shuts off standard output * but leaves the warnings to standard error, and verbose=0 * shuts off all output. * * @param verbose should diagnostic message be printed? * @return the strength of the array */ int oastr(bool verbose); /** * Similar to oastr, but only checking strength 1 * * From the original documentation: *
* Check whether the array in standard input is really * of strength 1. Use brute force. For OA( nrow, ncol, q, ? ) * it takes work roughly proportional to * ncol * nrow * q * to decide if ? >= 1. The user is warned if this is likely * to be too much work. * * The program calls exit(0) if the input array has strength * 1. It calls exit(1) if the array is not of strength 1, or if * the input is invalid, or if it is impossible to allocate enough * memory to find out. * * Note that an array of strength larger than 1 is a fortiori * of strength 1 and will pass this test. *
* * @param verbose should diagnostic message be printed? * @return true if the array is strength 1 */ bool oastr1(bool verbose); /** * Similar to oastr, but only checking strength 2 * * From the original documentation *
* Check whether the array in standard input is really * of strength 2. Use brute force. For OA( nrow, ncol, q, ? ) * it takes work roughly proportional to * ncol^2 * nrow * q^2/2 * to decide if ? >= 2. The user is warned if this is likely * to be too much work. * * The program calls exit(0) if the input array has strength * 2. It calls exit(1) if the array is not of strength 2, or if * the input is invalid, or if it is impossible to allocate enough * memory to find out. * * The program exits at the first sign that the array is * not of strength 2. This can save lots of work if the problem * shows up early, but it doesn't give a complete list of the * array's shortcomings. Such a list could be very large. * * Note that an array of strength larger than 2 is a fortiori * of strength 2 and will pass this test. *
* * @param verbose should diagnostic message be printed? * @return true if the array is strength 2 */ bool oastr2(bool verbose); /** * Similar to oastr, but only checking strength 3 * @param verbose should diagnostic message be printed? * @return true if the array is strength 3 */ bool oastr3(bool verbose); /** * Similar to oastr, but only checking strength 4 * @param verbose should diagnostic message be printed? * @return true if the array is strength 4 */ bool oastr4(bool verbose); /** * Similar to oastr, but only checking for strength t * @param t the strength to check for * @param verbose should diagnostic messages be printed? */ bool oastrt(int t, bool verbose); /** * row accessor * @return the number of rows in the orthogonal array */ int getnrows(); /** * column accessor * @return the number of columns in the orthogonal array */ int getncols(); /** * symbol accessor * @return the number of symbols in the orthogonal array */ int getq(); /** * orthogonal array accessor * @return the orthogonal array */ const bclib::matrix & getoa(); private: struct GF m_gf; /**< Galois Field */ bclib::matrix m_A; /**< Orthogonal Array */ int m_nrow; /**< the number of rows in orthogonal array */ int m_ncol; /**< the number of columns in the orthogonal array */ int m_q; /**< the number of symbols in the orthogonal array */ RUnif m_randomClass; /** * Create a Galois Field * @param q the number of symbols (0,...,q-1) * @throws std::runtime_error */ void createGaloisField(int q); /** * check to see if the memory for the array has been allocated * @throws std::runtime_error */ void checkDesignMemory(); /** * Check that the number of columns requested is less than the maximum * @param k the columns requested * @param maxColumns the maximum columns allowed * @return the columns allowed * @throws std::runtime_error */ int checkMaxColumns(int k, int maxColumns); /** * Check that the array was created successfully and assign the number of rows * * @param result code indicating if the array was created successful * @param nvalue the expected number of rows in the array * @param n [out] the number of rows * @throws std::runtime_error */ void checkResult(int result, int nvalue, int * n); }; inline void COrthogonalArray::oadimen() { PRINT_OUTPUT << "\nThe array has " << m_nrow << " rows, " << m_ncol << " columns and appears\n"; PRINT_OUTPUT << "to have " << m_q << " symbols, since the largest symbol is " << m_q - 1 << ".\n"; } inline int COrthogonalArray::getnrows() { return m_nrow; } inline int COrthogonalArray::getncols() { return m_ncol; } inline int COrthogonalArray::getq() { return m_q; } inline const bclib::matrix & COrthogonalArray::getoa() { return m_A; } } #endif lhs/src/matrix.h0000644000176200001440000006322013425401602013304 0ustar liggesusers/** * @file matrix.h * @author Robert Carnell * @copyright Copyright (c) 2013, Robert Carnell * * @license GNU Lesser General Public License (LGPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program. If not, see . */ #ifndef MATRIX_H #define MATRIX_H #include #include #include #include #include /** * @namespace bclib The bertcarnell template library namespace */ namespace bclib { // forward declare the iterator template class matrixIter; template class matrixConstIter; /** * Matrix Class * @tparam T a generic type of the kind that can be used in std::vector */ template class matrix { friend class matrixIter; /**< make the class a friend of the row-wise iterator */ friend class matrixIter; /**< make the class a friend of the column-wise iterator */ friend class matrixConstIter; /**< make the class a friend of the row-wise iterator */ friend class matrixConstIter; /**< make the class a friend of the column-wise iterator */ public: typedef typename std::vector::size_type size_type; /**< define the size_type as std::vector */ typedef typename std::vector::iterator iterator; /**< define iterator from the std::vector internals */ typedef typename std::vector::const_iterator const_iterator; /**< define the const iterator from the std::vector */ typedef matrixIter rowwise_iterator; /**< an iterator that iterates across rows then down columns */ typedef matrixIter columnwise_iterator; /**< an iterator that iterates down columns then across rows */ typedef matrixConstIter const_rowwise_iterator; /**< a const row-wise iterator */ typedef matrixConstIter const_columnwise_iterator; /**< a const column-wise iterator */ typedef ptrdiff_t difference_type; /**< define difference_type for consistency with stdlib */ typedef T value_type; /**< define value_type for consistency with stdlib */ typedef T * pointer; /**< define a pointer type for consistency with stdlib */ typedef T & reference; /**< define a reference type for consistency with stdlib */ private: size_type rows; /**< number of rows */ size_type cols; /**< number of columns */ std::vector elements; /**< array of elements */ bool bTranspose; /**< is the matrix transposed from creation */ /** * calculate tne location of the value in the vector holding the matrix values * @param row the row location * @param col the column location * @return the location of the value in the vector holding the matrix values */ size_type calcLocation(const size_type row, const size_type col) { return (!bTranspose) ? (row*cols + col) : (col*rows + row); } /** * calculate tne location of the value in the vector holding the matrix values * @param row the row location * @param col the column location * @return the location fo the value in the vector holding the matrix values */ size_type calcLocation(const size_type row, const size_type col) const { return (!bTranspose) ? (row*cols + col) : (col*rows + row); } public: /// The number of rows in the matrix size_type rowsize() const {return rows;}; /// The number of columns in the matrix size_type colsize() const {return cols;}; /** * matrix element access * @note does not check for index in range * @param row row index (zero based) * @param col column index (zero based) * @return a reference to the requested element */ T& operator()(size_type row, size_type col) { return elements[calcLocation(row, col)]; } /** * matrix element access * @note does not check for arguments out of range * @param row row index (zero based) * @param col column index (zero based) * @return a const reference to the requested element */ const T& operator()(size_type row, size_type col) const { return elements[calcLocation(row, col)]; } /** * matrix element access * @throws std::out_of_range from the internal std::vector * @param row row index (zero based) * @param col column index (zero based) * @return a const reference to the requested element */ const T& at(size_type row, size_type col) const { return elements.at(calcLocation(row, col)); } /** * matrix element access * @throws std::out_of_range from the internal std::vector * @param row row index (zero based) * @param col column index (zero based) * @return a reference to the requested element */ T& at(size_type row, size_type col) { return elements.at(calcLocation(row,col)); } /** * matrix element access * @throws std::out_of_range from the internal std::vector * @param i vector index (zero based) * @return a reference to the requested element */ T& at(size_type loc) { return elements.at(loc); } /** * matrix element access * @throws std::out_of_range from the internal std::vector * @param i vector index (zero based) * @return const a reference to the requested element */ const T& at(size_type loc) const { return elements.at(loc); } /// a pointer to the internal data array T* data() {return elements.data();}; /// get the internal data vector std::vector getDataVector() const {return elements;}; /// Default Constructor with zero rows and zero columns matrix(); /** * Constructor * @param rows the number of rows in the matrix * @param cols the number of columns in the matrix */ matrix(size_type rows, size_type cols); /** * Constructor * @param rows the number of rows in the matrix * @param cols the number of columns in the matrix * @param elementArray an array to use as the initial values */ matrix(size_type rows, size_type cols, const T* elementArray); /** * Constructor * @param rows the number of rows in the matrix * @param cols the number of columns in the matrix * @param elementVector a std::vector to use as the initial values */ matrix(size_type rows, size_type cols, const std::vector & elementVector); /** * Copy Constructor * @param the matrix to be copied */ matrix(const matrix &); /// Destructor ~matrix(); /** * Matrix assignment * @param right hand side matrix * @return the left hand side matrix */ matrix& operator=( const matrix& ); /** * Equality comparison operator * @param rhs the right hand side matrix * @return true if the matrices are equivalent */ bool operator==(const matrix & rhs) const; /** * Inequality comparison operator * @param rhs the right hand side matrix * @return true if the matrices are not equivalent */ bool operator!=(const matrix & rhs) const; /** * Get a row of the matrix as a std::vector * @note does not check to ensure the row is in range * @param row the row number * @return a vector representation of that row */ std::vector getrow(size_type row) const; /** * Get a row of the matrix as a std::vector * @throws std::out_of_range when the row is not in range * @param row the row number * @return a vector representation of that row */ std::vector getrow_at(size_type row) const; /** * Get a row of the matrix as a row matrix * @note does not check to ensure argument is in range * @param row the row number * @return a matrix representation of that row */ matrix getRowMatrix(size_type row) const; /** * Get a row of the matrix as a row matrix * @throws an out of range exception for an argument out of range * @param row the row number * @return a matrix representation of that row */ matrix getRowMatrix_at(size_type row) const; /** * get a column of the matrix as a vector * @note does not check the array bounds * @param col column number * @return a vector of the requested column */ std::vector getcol(size_type col) const; /** * Get a column of the matrix as a vector * @throws out_of_range error if the column requested is out of bounds * @param col the column number * @return a vector of the requested column */ std::vector getcol_at(size_type col) const; /** * Get a column of the matrix as a column matrix * @note does not check if the requested column is in bounds * @param col the column number * @return a column matrix of the requested column */ matrix getColumnMatrix(size_type col) const; /** * Get a column of the matrix as a column matrix * @throws if the requested column is out of range * @param col the column number * @return a column matrix of the requested column */ matrix getColumnMatrix_at(size_type col) const; /** * fill the matrix with a value * @param x the value to fill the matrix with */ void fill(const T & x) { elements.assign(rows*cols, x); }; /** * fill the matrix with a value * @param x the value to fill the matrix with */ //void fill(const T x) //{ // elements.assign(rows*cols, x); //}; /// Clear the matrix to zero rows and columns void clear(); /// return true if the matrix is empty bool isEmpty() const {return elements.empty();}; /// return a string representation of the matrix std::string toString() const; /// Transpose the matrix void transpose(); /// return true if this matrix is operating as a transposed matrix from the original definition bool isTransposed() const {return bTranspose;}; /********* Matrix Iterators *********/ /// an iterator for the beginning of the internal vector iterator begin() {return elements.begin();}; const_iterator begin() const {return elements.begin();}; /// An iterator for one iteration past the end of the internal vector iterator end() {return elements.end();}; const_iterator end() const {return elements.end();}; /// An iterator that operates along the matrix rows rowwise_iterator rowwisebegin() {return rowwise_iterator(*this, 0, 0);}; const_rowwise_iterator rowwisebegin() const {return const_rowwise_iterator(*this, 0, 0);}; /** * return a row wise iterator for the beginning of the ith row (0 based) * @param irow */ rowwise_iterator rowwisebegin(size_type irow) {return rowwise_iterator(*this, irow, 0);}; const_rowwise_iterator rowwisebegin(size_type irow) const {return const_rowwise_iterator(*this, irow, 0);}; /// An iterator that operates along the matrix row rowwise_iterator rowwiseend() {return rowwise_iterator(*this, rows, 0);}; const_rowwise_iterator rowwiseend() const {return const_rowwise_iterator(*this, rows, 0);}; /** * return a row wise iterator for the end of the ith row (0 based) * @param irow */ rowwise_iterator rowwiseend(size_type irow) {return rowwise_iterator(*this, irow+1, 0);}; const_rowwise_iterator rowwiseend(size_type irow) const {return const_rowwise_iterator(*this, irow+1, 0);}; /// An iterator that operates along the matrix columns columnwise_iterator columnwisebegin() {return columnwise_iterator(*this, 0, 0);}; const_columnwise_iterator columnwisebegin() const {return const_columnwise_iterator(*this, 0, 0);}; /** * return a column wise iterator for the beginning of the jth column (0 based) * @param irow */ columnwise_iterator columnwisebegin(size_type jcol) {return columnwise_iterator(*this, 0, jcol);}; const_columnwise_iterator columnwisebegin(size_type jcol) const {return const_columnwise_iterator(*this, 0, jcol);}; /// An iterator that operates along the matrix columns columnwise_iterator columnwiseend() {return columnwise_iterator(*this, 0, cols);}; const_columnwise_iterator columnwiseend() const {return const_columnwise_iterator(*this, 0, cols);}; /** * return a column wise iterator for the end of the jth column (0 based) * @param irow */ columnwise_iterator columnwiseend(size_type jcol) {return columnwise_iterator(*this, 0, jcol+1);}; const_columnwise_iterator columnwiseend(size_type jcol) const {return const_columnwise_iterator(*this, 0, jcol+1);}; }; /******************************************************************************/ /** * An iterator class for the matrix class * @tparam T the type of object stored in the matrix * @tparam ISROWWISE a boolean to indicate if the matrix is iterated row-wise */ template class matrixIter : public std::iterator { friend class matrixConstIter; private: matrix & myMatrix; /**< The object that the iterator is referencing */ typename matrix::size_type rows; /**< the row being pointed to */ typename matrix::size_type cols; /**< the column being pointed to */ public: /** * Constructor * @param mat the matrix being indexed * @param r the row location of the iterator * @param c the column location of the iterator */ matrixIter(matrix & mat, typename matrix::size_type r, typename matrix::size_type c) : myMatrix(mat), rows(r), cols(c) {} /// Equality operator bool operator==(const matrixIter & other) const; /// Inequality operator bool operator!=(const matrixIter & other) const { return !(*this == other); } /// pre-increment operator matrixIter & operator++(); /// post-increment operator matrixIter operator++(int); /// assignment operator matrixIter & operator=(const matrixIter & rhs); /// de-reference operator T & operator*() { return myMatrix(rows, cols); } }; /** * An const_iterator class for the matrix class * @tparam T the type of object stored in the matrix * @tparam ISROWWISE a boolean to indicate if the matrix is iterated row-wise */ template class matrixConstIter : public std::iterator { friend class matrixIter; private: const matrix & myMatrix; /**< The object that the iterator is referencing */ typename matrix::size_type rows; /**< the row being pointed to */ typename matrix::size_type cols; /**< the column being pointed to */ public: /** * Constructor * @param mat the matrix being indexed * @param r the row location of the iterator * @param c the column location of the iterator */ matrixConstIter(const matrix & mat, typename matrix::size_type r, typename matrix::size_type c) : myMatrix(mat), rows(r), cols(c) {} /** * Copy constructor from non-const to const * @param mi the matrix being copied */ matrixConstIter(const matrixIter & mi) : myMatrix(mi.myMatrix), rows(mi.rows), cols(mi.cols){} /// Equality operator bool operator==(const matrixConstIter & other) const; /// Inequality operator bool operator!=(const matrixConstIter & other) const { return !(*this == other); } /// pre-increment operator matrixConstIter & operator++(); /// post-increment operator matrixConstIter operator++(int); /// Assignment operator /** @TODO: does an assignment operator make sense for a const iterator? */ matrixConstIter & operator=(const matrixConstIter & rhs); /// de-reference operator const T & operator*() { return myMatrix(rows, cols); } }; // heavily influenced by: http://www.sj-vs.net/c-implementing-const_iterator-and-non-const-iterator-without-code-duplication/ /******************************************************************************/ template matrix::matrix(size_type rows, size_type cols) : rows(rows), cols(cols), bTranspose(false) { if ( rows == 0 || cols == 0 ) { throw std::range_error("attempt to create a degenerate matrix"); } elements = std::vector(rows*cols); } template matrix::matrix(size_type rows, size_type cols, const T* elementArray) : rows(rows), cols(cols), bTranspose(false) { if ( rows == 0 || cols == 0 ) { throw std::range_error("attempt to create a degenerate matrix"); } // initialize from array elements = std::vector(rows*cols); for (size_t i = 0; i < rows*cols; i++) { elements[i] = elementArray[i]; } } template matrix::matrix(size_type rows, size_type cols, const std::vector & elementVector) : rows(rows), cols(cols), bTranspose(false) { if ( rows == 0 || cols == 0 ) { throw std::range_error("attempt to create a degenerate matrix"); } if (elementVector.size() != rows*cols) { throw std::range_error("Input element Vector is not the right size"); } elements.assign(elementVector.begin(), elementVector.end()); } template matrix::matrix(const matrix & cp) : rows(cp.rows), cols(cp.cols), elements(cp.elements), bTranspose(cp.bTranspose) { } template matrix::~matrix() { } template matrix& matrix::operator=( const matrix& cp ) { if (cp.rows != rows || cp.cols != cols ) { rows = cp.rows; cols = cp.cols; } elements = cp.elements; bTranspose = cp.bTranspose; return *this; } template bool matrix::operator==(const matrix& cp) const { if (cp.rows != rows || cp.cols != cols) { return false; } return std::equal(elements.begin(), elements.end(), cp.elements.begin()); } template bool matrix::operator!=(const matrix & cp) const { if (*this == cp) { return false; } return true; } template std::vector matrix::getrow(size_type row) const { std::vector a = std::vector(cols); for (size_type j = 0; j < cols; j++) { a[j] = elements[calcLocation(row, j)]; } return a; } template std::vector matrix::getrow_at(size_type row) const { if (row >= rows) { std::ostringstream msg; msg << "row " << row << " was requested, but the matrix has " << rows << " rows"; throw std::out_of_range(msg.str().c_str()); } return getrow(row); } template matrix matrix::getRowMatrix(size_type row) const { // the simple method has an extra loop of assignment //std::vector a = this->getrow(i); //return matrix(1,cols,a); matrix a(1,cols); for (size_type j = 0; j < cols; j++) { a(0,j) = elements[calcLocation(row, j)]; } return a; } template matrix matrix::getRowMatrix_at(size_type row) const { if (row >= rows) { std::ostringstream msg; msg << "Row " << row << " was requested, but the matrix has " << rows << " rows"; throw std::out_of_range(msg.str().c_str()); } return getRowMatrix(row); } template std::vector matrix::getcol(size_type col) const { std::vector a = std::vector(rows); for (size_type i = 0; i < rows; i++) { a[i] = elements[calcLocation(i, col)]; } return a; } template std::vector matrix::getcol_at(size_type col) const { if (col >= cols) { std::ostringstream msg; msg << "Column " << col << " was requested, but the matrix has " << cols << " columns"; throw std::out_of_range(msg.str().c_str()); } return getcol(col); } template matrix matrix::getColumnMatrix(size_type col) const { matrix a(rows,1); for (size_type i = 0; i < rows; i++) { a(i,0) = elements[calcLocation(i, col)]; } return a; } template matrix matrix::getColumnMatrix_at(size_type col) const { if (col >= cols) { std::ostringstream msg; msg << "Column " << col << " was requested, but the matrix has " << cols << " columns"; throw std::out_of_range(msg.str().c_str()); } return getColumnMatrix(col); } template void matrix::clear() { elements.clear(); rows = 0; cols = 0; bTranspose = false; } template matrix::matrix() { rows = 0; cols = 0; elements = std::vector(); bTranspose = false; } template std::string matrix::toString() const { std::ostringstream msg; for (size_type irow = 0; irow < rows; irow++) { for (size_type jcol = 0; jcol < cols; jcol++) { msg << (*this).at(irow, jcol); if (cols > 1 && jcol < cols - 1) { msg << ","; } } msg << "\n"; } return msg.str(); } template void matrix::transpose() { // decide to not move data during transpose bTranspose = !bTranspose; size_type oldRows = rows; rows = cols; cols = oldRows; } /******************************************************************************/ template bool matrixIter::operator==(const matrixIter & other) const { if (this->myMatrix == other.myMatrix && this->rows == other.rows && this->cols == other.cols) { return true; } return false; } template matrixIter & matrixIter::operator++() { if (ISROWWISE) { if (cols < myMatrix.cols - 1) { cols++; return *this; } else { cols = 0; rows++; return *this; } } else // ISROWWISE = false { if (rows < myMatrix.rows - 1) { rows++; return *this; } else { rows = 0; cols++; return *this; } } } template matrixIter & matrixIter::operator=(const matrixIter & rhs) { // Check for self-assignment if (this == &rhs) { return *this; } else { this->myMatrix = rhs.myMatrix; this->rows = rhs.rows; this->cols = rhs.cols; return *this; } } template matrixIter matrixIter::operator++(int) { const matrixIter clone( *this ); ++(*this); return clone; } /******************************************************************************/ template bool matrixConstIter::operator==(const matrixConstIter & other) const { if (this->myMatrix == other.myMatrix && this->rows == other.rows && this->cols == other.cols) { return true; } return false; } template matrixConstIter & matrixConstIter::operator++() { if (ISROWWISE) { if (cols < myMatrix.cols - 1) { cols++; return *this; } else { cols = 0; rows++; return *this; } } else // ISROWWISE = false { if (rows < myMatrix.rows - 1) { rows++; return *this; } else { rows = 0; cols++; return *this; } } } template matrixConstIter & matrixConstIter::operator=(const matrixConstIter & rhs) { // Check for self-assignment if (this == &rhs) { return *this; } else { this->myMatrix = rhs.myMatrix; this->rows = rhs.rows; this->cols = rhs.cols; return *this; } } template matrixConstIter matrixConstIter::operator++(int) { const matrixConstIter clone( *this ); ++(*this); return clone; } } // end namespace #endif /* MATRIX_H */ lhs/src/lhs_r_utilities.cpp0000644000176200001440000001462513425401602015542 0ustar liggesusers/** * @file lhs_r_utilities.cpp * @author Robert Carnell * @copyright Copyright (c) 2014, Robert Carnell * * @license GNU General Public License (GPL v3) * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ #include "lhs_r_utilities.h" namespace lhs_r { void findorder_zero(const Rcpp::NumericVector & v, Rcpp::IntegerVector & order) { std::vector vlocal = Rcpp::as >(v); std::vector orderlocal(v.size()); bclib::findorder_zero(vlocal, orderlocal); order = Rcpp::IntegerVector::import(orderlocal.begin(), orderlocal.end()); // TODO: could we have done orderlocal = Rcpp::as >(order); ?? } Rcpp::NumericMatrix convertIntegerToNumericLhs(const bclib::matrix & intMat) { bclib::matrix::size_type rows; bclib::matrix::size_type cols; rows = intMat.rowsize(); cols = intMat.colsize(); Rcpp::NumericMatrix result(rows, cols); Rcpp::NumericVector eps = Rcpp::runif(static_cast(rows*cols)); unsigned int counter = 0; // I think this is right (iterate over rows within columns for (bclib::matrix::size_type col = 0; col < cols; col++) { for (bclib::matrix::size_type row = 0; row < rows; row++) { result(row, col) = static_cast(intMat(row, col) - 1) + eps[counter]; result(row, col) /= static_cast(rows); counter++; } } return result; } Rcpp::NumericMatrix convertIntegerToNumericLhs(const Rcpp::IntegerMatrix & intMat) { int n = intMat.rows(); int k = intMat.cols(); Rcpp::NumericMatrix result(n, k); Rcpp::NumericVector eps = Rcpp::runif(static_cast(n*k)); unsigned int counter = 0; // I think this is right (iterate over rows within columns for (bclib::matrix::size_type col = 0; col < static_cast(k); col++) { for (bclib::matrix::size_type row = 0; row < static_cast(n); row++) { result(row, col) = static_cast(intMat(row, col) - 1) + eps[counter]; result(row, col) /= static_cast(n); counter++; } } return result; } Rcpp::NumericMatrix convertMatrixToNumericLhs(const bclib::matrix & intMat) { //std::vector::iterator i = intMat.getDataVector().begin(); this iterator is row wise, but numeric matrix may be columnwise bclib::matrix::size_type rows = intMat.rowsize(); bclib::matrix::size_type cols = intMat.colsize(); //Rcpp::NumericMatrix result(rows, cols, i); Rcpp::NumericMatrix result(rows, cols); for (bclib::matrix::size_type i = 0; i < rows; i++) { for (bclib::matrix::size_type j = 0; j < cols; j++) { result(i, j) = intMat(i, j); } } return result; } Rcpp::IntegerVector runifint(unsigned int n, int min_int, int max_int) { Rcpp::NumericVector r = Rcpp::runif(n); Rcpp::IntegerVector intv(n); Rcpp::IntegerVector::iterator intv_it; Rcpp::NumericVector::iterator r_it; double range = static_cast(max_int + 1 - min_int); for (intv_it = intv.begin(), r_it = r.begin(); intv_it != intv.end() && r_it != r.end(); ++intv_it, ++r_it) { *intv_it = min_int + static_cast(floor(static_cast(*r_it) * range)); } return intv; } void checkArguments(int n, int k) { if (n == NA_INTEGER || k == NA_INTEGER) { throw std::invalid_argument("Invalid Argument: n and k may not be NA or NaN"); } else if (n < 1 || k < 1) { std::stringstream msg; msg << "Invalid Argument: n and k must be integers > 0, n=" << n << " k=" << k << "\n"; const std::string smsg = msg.str(); throw std::invalid_argument(smsg.c_str()); } } void checkArguments(int n, int k, int dup) { checkArguments(n, k); if (dup == NA_INTEGER) { throw std::invalid_argument("Invalid Argument: dup may not be NA or NaN"); } if (dup < 1) { std::stringstream msg; msg << "Invalid Argument: dup must be an integer > 0, dup=" << dup << "\n"; const std::string smsg = msg.str(); throw std::invalid_argument(smsg.c_str()); } } void checkArguments(int n, int k, int maxsweeps, double eps) { std::stringstream msg; checkArguments(n, k); if (maxsweeps == NA_INTEGER) { throw std::invalid_argument("Invalid Argument: maxsweeps may not be NA or NaN"); } else if (!R_FINITE(eps)) { throw std::invalid_argument("Invalid Argument: eps may not be Na, NaN, or +-Inf"); } else if (maxsweeps < 1) { msg << "Invalid Argument: maxsweeps must be an integer > 0, maxsweeps=" << maxsweeps << "\n"; const std::string smsg = msg.str(); throw std::invalid_argument(smsg.c_str()); } else if (eps <= 0 || eps >= 1) { msg << "Invalid Argument: eps must be a double on the interval (0,1), eps=" << eps << "\n"; const std::string smsg = msg.str(); throw std::invalid_argument(smsg.c_str()); } } Rcpp::NumericMatrix degenerateCase(int k, bclib::CRandom & oRandom) { Rcpp::NumericMatrix Z(1, k); for (int i = 0; i < k; i++) { Z(0, i) = oRandom.getNextRandom(); } return Z; } } // end namespace lhs/NAMESPACE0000644000176200001440000000110313425401460012251 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(augmentLHS) export(createAddelKemp) export(createAddelKemp3) export(createAddelKempN) export(createBose) export(createBoseBush) export(createBoseBushl) export(createBush) export(createBusht) export(create_oalhs) export(geneticLHS) export(improvedLHS) export(maximinLHS) export(oa_to_oalhs) export(optAugmentLHS) export(optSeededLHS) export(optimumLHS) export(randomLHS) import(Rcpp) importFrom(stats,dist) importFrom(stats,na.exclude) importFrom(stats,na.omit) importFrom(stats,runif) useDynLib(lhs) lhs/R/0000755000176200001440000000000013417500776011253 5ustar liggesuserslhs/R/lhs.R0000644000176200001440000000015213416455041012153 0ustar liggesusers# Copyright 2019 Robert Carnell #' @useDynLib lhs #' @keywords internal #' @import Rcpp "_PACKAGE" lhs/R/optSeededLHS.R0000644000176200001440000000434213425060547013660 0ustar liggesusers# Copyright 2019 Robert Carnell #' Optimum Seeded Latin Hypercube Sample #' #' Augments an existing Latin Hypercube Sample, adding points to the design, while #' maintaining the \emph{latin} properties of the design. This function then uses the #' columnwise pairwise (\acronym{CP}) algoritm to optimize the design. The original design is not necessarily maintained. #' #' @details #' Augments an existing Latin Hypercube Sample, adding points to the design, while #' maintaining the \emph{latin} properties of the design. This function then uses the #' \acronym{CP} algoritm to optimize the design. The original design #' is not necessarily maintained. #' #' @param seed The number of partitions (simulations or design points) #' @param m The number of additional points to add to the seed matrix \code{seed}. default value is zero. If m is zero then the seed design is optimized. #' @param maxSweeps The maximum number of times the CP algorithm is applied to all the columns. #' @param eps The optimal stopping criterion #' @param verbose Print informational messages #' #' @return An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] #' @export #' @seealso [randomLHS()], [geneticLHS()], [improvedLHS()], [maximinLHS()], and #' [optimumLHS()] to generate Latin Hypercube Samples. [optAugmentLHS()] and #' [augmentLHS()] to modify and augment existing designs. #' @keywords design #' #' @references #' Stein, M. (1987) Large Sample Properties of Simulations Using Latin Hypercube Sampling. #' \emph{Technometrics}. \bold{29}, 143--151. #' #' @examples #' set.seed(1234) #' a <- randomLHS(4,3) #' b <- optSeededLHS(a, 2, 2, .1) optSeededLHS <- function(seed, m=0, maxSweeps=2, eps=.1, verbose=FALSE) { k <- ncol(seed) if (!is.numeric(m) || is.na(m) || !is.finite(m) || m < 0) stop("m must be a positive number") if (m == 0) { N <- nrow(seed) Pold <- seed } else { N <- m + nrow(seed) Pold <- augmentLHS(seed, m) } result <- .Call("optSeededLHS_cpp", as.integer(N), as.integer(k), as.integer(maxSweeps), eps, Pold, as.logical(verbose), PACKAGE = "lhs") return(result) } lhs/R/geneticLHS.R0000644000176200001440000001003713425055402013352 0ustar liggesusers# Copyright 2019 Robert Carnell #' Latin Hypercube Sampling with a Genetic Algorithm #' #' Draws a Latin Hypercube Sample from a set of uniform distributions for use in #' creating a Latin Hypercube Design. This function attempts to optimize the #' sample with respect to the S optimality criterion through a genetic type #' algorithm. #' #' @details Latin hypercube sampling (LHS) was developed to generate a distribution #' of collections of parameter values from a multidimensional distribution. #' A square grid containing possible sample points is a Latin square iff there #' is only one sample in each row and each column. A Latin hypercube is the #' generalisation of this concept to an arbitrary number of dimensions. When #' sampling a function of \code{k} variables, the range of each variable is divided #' into \code{n} equally probable intervals. \code{n} sample points are then drawn such that a #' Latin Hypercube is created. Latin Hypercube sampling generates more efficient #' estimates of desired parameters than simple Monte Carlo sampling. #' #' This program generates a Latin Hypercube Sample by creating random permutations #' of the first \code{n} integers in each of \code{k} columns and then transforming those #' integers into n sections of a standard uniform distribution. Random values are #' then sampled from within each of the n sections. Once the sample is generated, #' the uniform sample from a column can be transformed to any distribution by #' using the quantile functions, e.g. qnorm(). Different columns can have #' different distributions. #' #' S-optimality seeks to maximize the mean distance from each design point to all #' the other points in the design, so the points are as spread out as possible. #' #' Genetic Algorithm: #' \enumerate{ #' \item Generate \code{pop} random latin hypercube designs of size \code{n} by \code{k} #' \item Calculate the S optimality measure of each design #' \item Keep the best design in the first position and throw away half of the rest of the population #' \item Take a random column out of the best matrix and place it in a random column of each of the other matricies, and take a random column out of each of the other matricies and put it in copies of the best matrix thereby causing the progeny #' \item For each of the progeny, cause a genetic mutation \code{pMut} percent of the time. The mutation is accomplished by swtching two elements in a column #' } #' #' @param n The number of partitions (simulations or design points or rows) #' @param k The number of replications (variables or columns) #' @param pop The number of designs in the initial population #' @param gen The number of generations over which the algorithm is applied #' @param pMut The probability with which a mutation occurs in a column of the progeny #' @param criterium The optimality criterium of the algorithm. Default is \code{S}. \code{Maximin} is also supported #' @param verbose Print informational messages. Default is \code{FALSE} #' #' @return An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] #' @export #' @references #' Stocki, R. (2005) A method to improve design reliability using optimal Latin hypercube sampling #' \emph{Computer Assisted Mechanics and Engineering Sciences} \bold{12}, 87--105. #' #' Stein, M. (1987) Large Sample Properties of Simulations Using Latin Hypercube Sampling. #' \emph{Technometrics}. \bold{29}, 143--151. #' #' @seealso [randomLHS()], [improvedLHS()], [maximinLHS()], #' and [optimumLHS()] to generate Latin Hypercube Samples. [optAugmentLHS()] #' [optSeededLHS()], and [augtmentLHS()] to modify and augment existing designs. #' #' @keywords design #' @author Rob Carnell #' #' @examples #' set.seed(1234) #' A <- geneticLHS(4, 3, 50, 5, .25) geneticLHS <- function(n=10, k=2, pop=100, gen=4, pMut=.1, criterium="S", verbose=FALSE) { .Call("geneticLHS_cpp", as.integer(n), as.integer(k), as.integer(pop), as.integer(gen), pMut, criterium, as.logical(verbose), PACKAGE = "lhs") } lhs/R/augmentLHS.R0000644000176200001440000000717613425055135013411 0ustar liggesusers# Copyright 2019 Robert Carnell #' Augment a Latin Hypercube Design #' #' Augments an existing Latin Hypercube Sample, adding points to the design, while #' maintaining the \emph{latin} properties of the design. #' #' @details Augments an existing Latin Hypercube Sample, adding points to the design, while #' maintaining the \emph{latin} properties of the design. Augmentation is perfomed #' in a random manner. #' #' The algorithm used by this function has the following steps. #' First, create a new matrix to hold the candidate points after the design has #' been re-partitioned into \eqn{(n+m)^{2}}{(n+m)^2} cells, where n is number of #' points in the original \code{lhs} matrix. Then randomly sweep through each #' column (1\ldots\code{k}) in the repartitioned design to find the missing cells. #' For each column (variable), randomly search for an empty row, generate a #' random value that fits in that row, record the value in the new matrix. #' The new matrix can contain more filled cells than \code{m} unles \eqn{m = 2n}, #' in which case the new matrix will contain exactly \code{m} filled cells. #' Finally, keep only the first m rows of the new matrix. It is guaranteed to #' have \code{m} full rows in the new matrix. The deleted rows are partially full. #' The additional candidate points are selected randomly due to the random search #' for empty cells. #' #' @param lhs The Latin Hypercube Design to which points are to be added. #' Contains an existing latin hypercube design with a number of rows equal #' to the points in the design (simulations) and a number of columns equal #' to the number of variables (parameters). The values of each cell must be #' between 0 and 1 and uniformly distributed #' @param m The number of additional points to add to matrix \code{lhs} #' #' @return An \code{n} by \code{k} Latin Hypercube Sample matrix with values #' uniformly distributed on [0,1] #' @export #' @importFrom stats runif #' #' @author Rob Carnell #' @references #' Stein, M. (1987) Large Sample Properties of Simulations Using Latin #' Hypercube Sampling. \emph{Technometrics}. \bold{29}, 143--151. #' #' @keywords design #' #' @seealso [randomLHS()], [geneticLHS()], [improvedLHS()], [maximinLHS()], #' and [optimumLHS()] to generate Latin Hypercube Samples. [optAugmentLHS()] #' and [optSeededLHS()] to modify and augment existing designs. #' #' @examples #' set.seed(1234) #' a <- randomLHS(4,3) #' b <- augmentLHS(a, 2) augmentLHS <- function(lhs, m=1) { if (!is.matrix(lhs)) stop("Input Latin Hypercube Design must be in the Matrix class\n") if (length(m) != 1) stop("m may not be a vector") if (is.na(m) | is.infinite(m)) stop("m may not be infinite, NA, or NaN") if (m != floor(m) | m < 1) stop("m must be a positive integer\n") if (any(is.na(lhs))) stop("Input Design cannot contain any NA entries\n") if (any(lhs < 0 | lhs > 1)) stop(paste("Input Latin Hypercube Design must have entries on the ", "interval [0,1] which are uniformly distributed\n", sep = "")) K <- ncol(lhs) N <- nrow(lhs) colvec <- order(runif(K)) rowvec <- order(runif(N + m)) B <- matrix(nrow = (N + m), ncol = K) for (j in colvec) { newrow <- 0 for (i in rowvec) { if (!(any((i - 1)/(N + m) <= lhs[ ,j] & lhs[ ,j] <= i/(N + m)))) { newrow <- newrow + 1 B[newrow, j] <- runif(1, (i - 1)/(N + m), i/(N + m)) } } } if (is.matrix(B[1:m,])) { E <- rbind(lhs, B[1:m, ]) } else { E <- rbind(lhs, matrix(B[1:m,], nrow = m, ncol = K)) } row.names(E) <- NULL return(E) } lhs/R/create_oalhs.R0000644000176200001440000000147613425055207014030 0ustar liggesusers# Copyright 2019 Robert Carnell #' Create an orthogonal array Latin hypercube #' #' @param n the number of samples or rows in the LHS (integer) #' @param k the number of parameters or columns in the LHS (integer) #' @param bChooseLargerDesign should a larger oa design be chosen than the n and k requested? #' @param bverbose should information be printed with execution #' #' @return a numeric matrix which is an orthogonal array Latin hypercube sample #' @export #' #' @examples #' set.seed(34) #' A <- create_oalhs(9, 4, TRUE, FALSE) #' B <- create_oalhs(9, 4, TRUE, FALSE) create_oalhs <- function(n, k, bChooseLargerDesign, bverbose) { return(.Call("create_oalhs", as.integer(n), as.integer(k), as.logical(bChooseLargerDesign), as.logical(bverbose), PACKAGE = "lhs")) } lhs/R/improvedLHS.r0000644000176200001440000000600313425055432013622 0ustar liggesusers# Copyright 2019 Robert Carnell #' Improved Latin Hypercube Sample #' #' Draws a Latin Hypercube Sample from a set of uniform distributions for use in #' creating a Latin Hypercube Design. This function attempts to optimize the #' sample with respect to an optimum euclidean distance between design points. #' #' @details Latin hypercube sampling (LHS) was developed to generate a distribution #' of collections of parameter values from a multidimensional distribution. #' A square grid containing possible sample points is a Latin square iff there #' is only one sample in each row and each column. A Latin hypercube is the #' generalisation of this concept to an arbitrary number of dimensions. When #' sampling a function of \code{k} variables, the range of each variable is divided #' into \code{n} equally probable intervals. \code{n} sample points are then drawn such that a #' Latin Hypercube is created. Latin Hypercube sampling generates more efficient #' estimates of desired parameters than simple Monte Carlo sampling. #' #' This program generates a Latin Hypercube Sample by creating random permutations #' of the first \code{n} integers in each of \code{k} columns and then transforming those #' integers into n sections of a standard uniform distribution. Random values are #' then sampled from within each of the n sections. Once the sample is generated, #' the uniform sample from a column can be transformed to any distribution byusing the quantile functions, e.g. qnorm(). Different columns can have #' different distributions. #' #' This function attempts to optimize the sample with respect to an optimum #' euclidean distance between design points. #' \deqn{Optimum distance = frac{n}{n^{\frac{1.0}{k}}}}{Optimum distance = n/n^(1.0/k)} #' #' @param n The number of partitions (simulations or design points or rows) #' @param k The number of replications (variables or columns) #' @param dup A factor that determines the number of candidate points used in the #' search. A multiple of the number of remaining points than can be added. #' #' @return An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] #' @export #' @keywords design #' #' @references #' Beachkofski, B., Grandhi, R. (2002) Improved Distributed Hypercube Sampling #' \emph{American Institute of Aeronautics and Astronautics Paper} \bold{1274}. #' #' This function is based on the MATLAB program written by John Burkardt and modified 16 Feb 2005 #' \url{http://www.csit.fsu.edu/~burkardt/m_src/ihs/ihs.m} #' #' @seealso [randomLHS()], [geneticLHS()], [maximinLHS()], and [optimumLHS()] #' to generate Latin Hypercube Samples. [optAugmentLHS()], [optSeededLHS()], and #' [augmentLHS()] to modify and augment existing designs. #' #' @examples #' set.seed(1234) #' A <- improvedLHS(4, 3, 2) improvedLHS <- function(n, k, dup=1) { result <- .Call("improvedLHS_cpp", as.integer(n), as.integer(k), as.integer(dup), PACKAGE = "lhs") return(result) } lhs/R/createOA.R0000644000176200001440000001404713425055337013064 0ustar liggesusers# Copyright 2019 Robert Carnell #' Create an orthogonal array using the Bose algorithm #' #' @param q the number of symbols in the array #' @param ncol number of parameters or columns #' @param bRandom should the array be randomized #' @return an orthogonal array #' @export #' @examples A <- createBose(3, 3, FALSE) #' B <- createBose(5, 4, TRUE) #' @seealso Other methods to create orthogonal arrays [createBush()], #' [createBoseBush()], [createAddelKemp()], [createAddelKemp3()], #' [createAddelKempN()], [createBusht()], [createBoseBushl()] createBose <- function(q, ncol, bRandom=TRUE) { return(.Call("oa_type1", "bose", as.integer(q), as.integer(ncol), as.logical(bRandom), PACKAGE = "lhs")) } #' Create an orthogonal array using the Bose-Bush algorithm #' #' @param q the number of symbols in the array #' @param ncol number of parameters or columns #' @param bRandom should the array be randomized #' @return an orthogonal array #' @export #' @examples A <- createBoseBush(4, 3, FALSE) #' B <- createBoseBush(8, 3, TRUE) #' @seealso Other methods to create orthogonal arrays [createBush()], #' [createBose()], [createAddelKemp()], [createAddelKemp3()], #' [createAddelKempN()], [createBusht()], [createBoseBushl()] createBoseBush <- function(q, ncol, bRandom=TRUE) { return(.Call("oa_type1", "bosebush", as.integer(q), as.integer(ncol), as.logical(bRandom), PACKAGE = "lhs")) } #' Create an orthogonal array using the Bush algorithm #' #' @param q the number of symbols in the array #' @param ncol number of parameters or columns #' @param bRandom should the array be randomized #' @return an orthogonal array #' @export #' @examples A <- createBush(3, 3, FALSE) #' B <- createBush(4, 5, TRUE) #' @seealso Other methods to create orthogonal arrays [createBoseBush()], #' [createBose()], [createAddelKemp()], [createAddelKemp3()], #' [createAddelKempN()], [createBusht()], [createBoseBushl()] createBush <- function(q, ncol, bRandom=TRUE) { return(.Call("oa_type1", "bush", as.integer(q), as.integer(ncol), as.logical(bRandom), PACKAGE = "lhs")) } #' Create an orthogonal array using the Addelman-Kempthorne algorithm #' #' @param q the number of symbols in the array #' @param ncol number of parameters or columns #' @param bRandom should the array be randomized #' @return an orthogonal array #' @export #' @examples A <- createAddelKemp(3, 3, TRUE) #' B <- createAddelKemp(3, 5, FALSE) #' @seealso Other methods to create orthogonal arrays [createBoseBush()], #' [createBose()], [createAddelKemp3()], #' [createAddelKempN()], [createBusht()], [createBoseBushl()] createAddelKemp <- function(q, ncol, bRandom=TRUE) { return(.Call("oa_type1", "addelkemp", as.integer(q), as.integer(ncol), as.logical(bRandom), PACKAGE = "lhs")) } #' Create an orthogonal array using the Addelman-Kempthorne algorithm #' with 2*q^3 rows #' #' @param q the number of symbols in the array #' @param ncol number of parameters or columns #' @param bRandom should the array be randomized #' @return an orthogonal array #' @export #' @examples A <- createAddelKemp3(3, 3, TRUE) #' B <- createAddelKemp3(3, 5, FALSE) #' @seealso Other methods to create orthogonal arrays [createBushBush()], #' [createBose()], [createAddelKemp()], #' [createAddelKempN()], [createBusht()], [createBoseBushl()] createAddelKemp3 <- function(q, ncol, bRandom=TRUE) { return(.Call("oa_type1", "addelkemp3", as.integer(q), as.integer(ncol), as.logical(bRandom), PACKAGE = "lhs")) } #' Create an orthogonal array using the Bush algorithm with alternate strength #' #' @param q the number of symbols in the array #' @param ncol number of parameters or columns #' @param strength the strength of the array to be created #' @param bRandom should the array be randomized #' @return an orthogonal array #' @export #' @examples #' set.seed(1234) #' A <- createBusht(3, 4, 2, TRUE) #' B <- createBusht(3, 4, 3, FALSE) #' G <- createBusht(3, 4, 3, TRUE) #' @seealso Other methods to create orthogonal arrays [createBoseBush()], #' [createBose()], [createAddelKemp()], [createAddelKemp3()], #' [createAddelKempN()], [createBoseBushl()] createBusht <- function(q, ncol, strength, bRandom=TRUE) { return(.Call("oa_type2", "busht", as.integer(strength), as.integer(q), as.integer(ncol), as.logical(bRandom), PACKAGE = "lhs")) } #' Create an orthogonal array using the Bose-Bush algorithm with alternate strength >= 3 #' #' @param q the number of symbols in the array #' @param ncol number of parameters or columns #' @param lambda the lambda of the BoseBush algorithm #' @param bRandom should the array be randomized #' @return an orthogonal array #' @export #' @examples A <- createBoseBushl(3, 3, 3, TRUE) #' B <- createBoseBushl(4, 4, 16, TRUE) #' @seealso Other methods to create orthogonal arrays [createBoseBush()], #' [createBose()], [createBush()], [createAddelKemp()], [createAddelKemp3()], #' [createAddelKempN()], [createBusht()] createBoseBushl <- function(q, ncol, lambda, bRandom=TRUE) { return(.Call("oa_type2", "bosebushl", as.integer(lambda), as.integer(q), as.integer(ncol), as.logical(bRandom), PACKAGE = "lhs")) } #' Create an orthogonal array using the Addelman-Kempthorne algorithm with #' alternate strength #' #' @param q the number of symbols in the array #' @param ncol number of parameters or columns #' @param exponent the exponent on q #' @param bRandom should the array be randomized #' @return an orthogonal array #' @export #' @examples A <- createAddelKempN(3, 4, 3, TRUE) #' B <- createAddelKempN(3, 4, 4, TRUE) #' @seealso Other methods to create orthogonal arrays [createBoseBush()], #' [createBose()], [createBush()], [createAddelKemp()], [createAddelKemp3()], #' [createBusht()], [createBoseBushl()] createAddelKempN <- function(q, ncol, exponent, bRandom=TRUE) { return(.Call("oa_type2", "addelkempn", as.integer(exponent), as.integer(q), as.integer(ncol), as.logical(bRandom), PACKAGE = "lhs")) } lhs/R/randomLHS.r0000644000176200001440000000171713416442547013273 0ustar liggesusers# Copyright 2019 Robert Carnell #' Construct a random Latin hypercube design #' #' \code{randomLHS(4,3)} returns a 4x3 matrix with each column #' constructed as follows: A random permutation of (1,2,3,4) is #' generated, say (3,1,2,4) for each of K columns. Then a uniform #' random number is picked from each indicated quartile. In this #' example a random number between .5 and .75 is chosen, then one between #' 0 and .25, then one between .25 and .5, finally one between #' .75 and 1. #' #' @param n the number of rows or samples #' @param k the number of columns or parameters/variables #' @param preserveDraw should the draw be constructed so that it is the same for variable numbers of columns? #' @return a Latin hypercube sample #' @export #' #' @examples #' a <- randomLHS(5, 3) randomLHS <- function(n, k, preserveDraw=FALSE) { .Call("randomLHS_cpp", as.integer(n), as.integer(k), as.logical(preserveDraw), PACKAGE = "lhs") } lhs/R/oa_to_oalhs.R0000644000176200001440000000201213425355365013661 0ustar liggesusers# Copyright 2019 Robert Carnell #' Create a Latin hypercube from an orthogonal array #' #' @param n the number of samples or rows in the LHS (integer) #' @param k the number of parameters or columns in the LHS (integer) #' @param oa the orthogonal array to be used as the basis for the LHS (matrix of integers) or data.frame of factors #' #' @return a numeric matrix which is a Latin hypercube sample #' @export #' #' @examples #' oa <- createBose(3, 4, TRUE) #' B <- oa_to_oalhs(9, 4, oa) oa_to_oalhs <- function(n, k, oa) { if (is.integer(oa) && is.matrix(oa)) { return(.Call("oa_to_lhs", as.integer(n), as.integer(k), oa, FALSE, PACKAGE = "lhs")) } else if (is.data.frame(oa)) { Y <- as.matrix(oa) Z <- matrix(as.integer(Y), nrow = nrow(oa), ncol = ncol(oa)) return(.Call("oa_to_lhs", as.integer(n), as.integer(k), Z, FALSE, PACKAGE = "lhs")) } else { stop("oa must be an integer matrix or it must be a data.frame of factors") } } lhs/R/runifint.r0000644000176200001440000000076713416423355013302 0ustar liggesusers# Copyright 2019 Robert Carnell #' Create a Random Sample of Uniform Integers #' #' @param n The number of samples #' @param min_int the minimum integer \code{x >= min_int} #' @param max_int the maximum integer \code{x <= max_int} #' #' @return the sample sample of size \code{n} #' @importFrom stats runif runifint <- function(n=1, min_int=0, max_int=1) { r <- runif(n, min = 0, max = 1) int <- min_int + floor(r * (max_int + 1 - min_int)) int <- pmin(int, max_int) return(int) } lhs/R/optimumLHS.R0000644000176200001440000000626313425060436013437 0ustar liggesusers# Copyright 2019 Robert Carnell #' Optimum Latin Hypercube Sample #' #' Draws a Latin Hypercube Sample from a set of uniform distributions for use in #' creating a Latin Hypercube Design. This function uses the Columnwise #' Pairwise (\acronym{CP}) algorithm to generate an optimal design with respect to the S #' optimality criterion. #' #' @details Latin hypercube sampling (LHS) was developed to generate a distribution #' of collections of parameter values from a multidimensional distribution. #' A square grid containing possible sample points is a Latin square iff there #' is only one sample in each row and each column. A Latin hypercube is the #' generalisation of this concept to an arbitrary number of dimensions. When #' sampling a function of \code{k} variables, the range of each variable is divided #' into \code{n} equally probable intervals. \code{n} sample points are then drawn such that a #' Latin Hypercube is created. Latin Hypercube sampling generates more efficient #' estimates of desired parameters than simple Monte Carlo sampling. #' #' This program generates a Latin Hypercube Sample by creating random permutations #' of the first \code{n} integers in each of \code{k} columns and then transforming those #' integers into n sections of a standard uniform distribution. Random values are #' then sampled from within each of the n sections. Once the sample is generated, #' the uniform sample from a column can be transformed to any distribution by #' using the quantile functions, e.g. qnorm(). Different columns can have #' different distributions. #' #' S-optimality seeks to maximize the mean distance from each design point to all #' the other points in the design, so the points are as spread out as possible. #' #' This function uses the \acronym{CP} algorithm to generate an optimal #' design with respect to the S optimality criterion. #' #' @param n The number of partitions (simulations or design points or rows) #' @param k The number of replications (variables or columns) #' @param maxSweeps The maximum number of times the CP algorithm is applied to all the columns. #' @param eps The optimal stopping criterion. Algorithm stops when the change in #' optimality measure is less than eps*100\% of the previous value. #' @param verbose Print informational messages #' #' @return An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] #' @export #' @seealso [randomLHS()], [geneticLHS()], [improvedLHS()] and [maximinLHS()] #' to generate Latin Hypercube Samples. [optAugmentLHS()], [optSeededLHS()], and #' [augmentLHS()] to modify and augment existing designs. #' @keywords design #' #' @references #' Stocki, R. (2005) A method to improve design reliability using optimal Latin hypercube sampling #' \emph{Computer Assisted Mechanics and Engineering Sciences} \bold{12}, 87--105. #' #' @examples #' A <- optimumLHS(4, 3, 5, .05) optimumLHS <- function(n=10, k=2, maxSweeps=2, eps=.1, verbose=FALSE) { result <- .Call("optimumLHS_cpp", as.integer(n), as.integer(k), as.integer(maxSweeps), eps, as.logical(verbose), PACKAGE = "lhs") return(result) } lhs/R/maximinLHS.R0000644000176200001440000001641213425060016013376 0ustar liggesusers# Copyright 2019 Robert Carnell #' Maximin Latin Hypercube Sample #' #' Draws a Latin Hypercube Sample from a set of uniform distributions for use in #' creating a Latin Hypercube Design. This function attempts to optimize the #' sample by maximizing the minium distance between design points (maximin criteria). #' #' @details Latin hypercube sampling (LHS) was developed to generate a distribution #' of collections of parameter values from a multidimensional distribution. #' A square grid containing possible sample points is a Latin square iff there #' is only one sample in each row and each column. A Latin hypercube is the #' generalisation of this concept to an arbitrary number of dimensions. When #' sampling a function of \code{k} variables, the range of each variable is divided #' into \code{n} equally probable intervals. \code{n} sample points are then drawn such that a #' Latin Hypercube is created. Latin Hypercube sampling generates more efficient #' estimates of desired parameters than simple Monte Carlo sampling. #' #' This program generates a Latin Hypercube Sample by creating random permutations #' of the first \code{n} integers in each of \code{k} columns and then transforming those #' integers into n sections of a standard uniform distribution. Random values are #' then sampled from within each of the n sections. Once the sample is generated, #' the uniform sample from a column can be transformed to any distribution by #' using the quantile functions, e.g. qnorm(). Different columns can have #' different distributions. #' #' Here, values are added to the design one by one such that the maximin criteria is #' satisfied. #' #' @param n The number of partitions (simulations or design points or rows) #' @param k The number of replications (variables or columns) #' @param method \code{build} or \code{iterative} is the method of LHS creation. #' \code{build} finds the next best point while constructing the LHS. #' \code{iterative} optimizes the resulting sample on [0,1] or sample grid on [1,N] #' @param dup A factor that determines the number of candidate points used in the #' search. A multiple of the number of remaining points than can be #' added. This is used when \code{method="build"} #' @param eps The minimum percent change in the minimum distance used in the #' \code{iterative} method #' @param maxIter The maximum number of iterations to use in the \code{iterative} method #' @param optimize.on \code{grid} or \code{result} gives the basis of the optimization. #' \code{grid} optimizes the LHS on the underlying integer grid. #' \code{result} optimizes the resulting sample on [0,1] #' @param debug prints additional information about the process of the optimization #' #' @return An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] #' @export #' @keywords design #' @importFrom stats dist #' #' @references #' Stein, M. (1987) Large Sample Properties of Simulations Using Latin Hypercube Sampling. #' \emph{Technometrics}. \bold{29}, 143--151. #' #' This function is motivated by the MATLAB program written by John Burkardt and modified 16 Feb 2005 #' \url{http://www.csit.fsu.edu/~burkardt/m_src/ihs/ihs.m} #' #' @seealso [randomLHS()], [geneticLHS()], [improvedLHS()] and [optimumLHS()] #' to generate Latin Hypercube Samples. [optAugmentLHS()], [optSeededLHS()], and #' [augmentLHS()] to modify and augment existing designs. #' #' @examples #' set.seed(1234) #' A1 <- maximinLHS(4, 3, dup=2) #' A2 <- maximinLHS(4, 3, method="build", dup=2) #' A3 <- maximinLHS(4, 3, method="iterative", eps=0.05, maxIter=100, optimize.on="grid") #' A4 <- maximinLHS(4, 3, method="iterative", eps=0.05, maxIter=100, optimize.on="result") maximinLHS <- function(n, k, method="build", dup=1, eps=0.05, maxIter=100, optimize.on="grid", debug=FALSE) { if (!(method %in% c("build","iterative"))) stop("Method not recognized. Please use 'build' or 'iterative'") if (!(optimize.on %in% c("grid","result"))) stop("optimize.on parameter must be 'result' or 'grid'") if (debug) cat("Debug info:\n") if (method == "build") { if (optimize.on == "result") { if (debug) cat(paste0("\toptimize.on=", optimize.on, " method=", method, "\n")) warning("when method='build' then optimize.on is set to 'grid'") } result <- .Call("maximinLHS_cpp", as.integer(n), as.integer(k), as.integer(dup), PACKAGE = "lhs") return(result) } else if (method == "iterative") { if (length(n) != 1 | length(k) != 1 | length(dup) != 1) stop("n, k, and dup may not be vectors") if (any(is.na(c(n,k,dup)))) stop("n, k, and dup may not be NA or NaN") if (any(is.infinite(c(n,k,dup)))) stop("n, k, and dup may not be infinite") if (n != floor(n) | n < 1) stop("n must be a positive integer") if (k != floor(k) | k < 1) stop("k must be a positive integer") if (dup != floor(dup) | dup < 1) stop("The dup factor must be a positive integer") adjust <- runif(n*k) if (optimize.on == "result") { X <- randomLHS(n, k, preserveDraw = FALSE) } else if (optimize.on == "grid") { X <- sapply(1:k, function(x) order(runif(n))) } Y <- X minDist <- min(dist(X)) # the columns of res are the ith row, mth row, jth column, and the min distance when those are exchanged res <- matrix(0, nrow = k*choose(n, 2), ncol = 4) iter <- 1 while (iter < maxIter) { # counter is the counter down the rows of res counter <- 1 # try all pairwise row swaps within each column in the LHS for (j in 1:k) { for (i in 1:(n - 1)) { for (m in (i + 1):n) { # swap Y[i,j] <- X[m,j] Y[m,j] <- X[i,j] # record the result res[counter,1] <- i res[counter,2] <- m res[counter,3] <- j res[counter,4] <- min(dist(Y)) # swap back Y[i,j] <- X[i,j] Y[m,j] <- X[m,j] counter <- counter + 1 } } } # find the best swap ind <- which.max(res[,4]) # make the swap Y[res[ind,1],res[ind,3]] <- X[res[ind,2],res[ind,3]] Y[res[ind,2],res[ind,3]] <- X[res[ind,1],res[ind,3]] temp <- min(dist(Y)) # test the new minimum distance between points if (temp < minDist) { if (debug) cat("\tstopped because no changes improved minimum distance\n") if (optimize.on == "result") return(X) else return((X - 1 + matrix(adjust, nrow = n, ncol = k))/n) } if (res[ind,4] < (1 + eps)*minDist) { if (debug) cat("\tstopped because the minimum improvement was not reached\n") if (optimize.on == "result") return(Y) else return((Y - 1 + matrix(adjust, nrow = n, ncol = k))/n) } else { minDist <- temp X <- Y } iter <- iter + 1 } if (debug) cat("\tstoped on iterations\n") if (optimize.on == "result") return(Y) else return((Y - 1 + matrix(adjust, nrow = n, ncol = k))/n) } } lhs/R/optAugmentLHS.R0000644000176200001440000000722313425061474014070 0ustar liggesusers# Copyright 2019 Robert Carnell #' Optimal Augmented Latin Hypercube Sample #' #' Augments an existing Latin Hypercube Sample, adding points to the design, while #' maintaining the \emph{latin} properties of the design. This function attempts to #' add the points to the design in an optimal way. #' #' Augments an existing Latin Hypercube Sample, adding points to the design, while #' maintaining the \emph{latin} properties of the design. This function attempts to #' add the points to the design in a way that maximizes S optimality. #' #' S-optimality seeks to maximize the mean distance from each design point to all #' the other points in the design, so the points are as spread out as possible. #' #' @param lhs The Latin Hypercube Design to which points are to be added #' @param m The number of additional points to add to matrix \code{lhs} #' @param mult \code{m*mult} random candidate points will be created. #' #' @return An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] #' @export #' @keywords design #' @seealso #' [randomLHS()], [geneticLHS()], [improvedLHS()], [maximinLHS()], and #' [optimumLHS()] to generate Latin Hypercube Samples. [optSeededLHS()] and #' [augmentLHS()] to modify and augment existing designs. #' @importFrom stats runif na.exclude na.omit #' #' @references #' Stein, M. (1987) Large Sample Properties of Simulations Using Latin Hypercube Sampling. #' \emph{Technometrics}. \bold{29}, 143--151. #' #' @examples #' set.seed(1234) #' a <- randomLHS(4,3) #' b <- optAugmentLHS(a, 2, 3) optAugmentLHS <- function(lhs, m=1, mult=2) { if (is.matrix(lhs) == FALSE) stop("Input Design must be in the Matrix class\n") if (length(m) != 1 | length(mult) != 1) stop("m and mult may not be vectors") if (is.na(m) | is.infinite(m)) stop("m may not be infinite, NA, or NaN") if (is.na(mult) | is.infinite(mult)) stop("mult may not be infinite, NA, or NaN") if (m != floor(m) | m < 1) stop("m must be a positive integer\n") if (any(is.na(lhs) == TRUE)) stop("Input Design cannot contain any NA entries\n") if (any(lhs < 0 | lhs > 1)) stop("Input Design must have entries on the interval [0,1]\n") K <- ncol(lhs) N <- nrow(lhs) colvec <- order(runif(K)) rowvec <- order(runif(N + m)) B <- matrix(nrow = (N + m), ncol = K) for (j in colvec) { newrow <- 0 for (i in rowvec) { if ((any((i - 1)/(N + m) <= lhs[ ,j] & lhs[ ,j] <= i/(N + m))) == FALSE) { newrow <- newrow + 1 B[newrow, j] <- runif(1, (i - 1)/(N + m), i/(N + m)) } } } lhs <- rbind(lhs, matrix(nrow = m, ncol = K)) for (k in 1:m) { P <- matrix(nrow = m*mult, ncol = K) for (i in 1:K) { P[,i] <- runifint(m*mult, 1, length(na.exclude(B[,i]))) } for (i in 1:K) { for (j in 1:(m*mult)) { P[j, i] <- B[P[j, i], i] } } vec <- numeric(K) dist1 <- 0 maxdist <- .Machine$double.xmin for (i in 1:(m*mult - k + 1)) { dist1 <- numeric(N + k - 1) for (j in 1:(N + k - 1)) { vec <- P[i,] - lhs[j,] dist1[j] <- vec %*% vec } if (sum(dist1) > maxdist) { maxdist <- sum(dist1) maxrow <- i } } lhs[N + k,] <- P[maxrow,] for (i in 1:K) { for (j in 1:length(na.omit(B[,i]))) { if (P[maxrow,i] == B[j,i]) B[j,i] <- NA } } for (i in 1:K) { if (length(na.omit(B[,i])) == 0) next u <- length(na.omit(B[,i])) B[1:u,i] <- na.omit(B[,i]) B[(u + 1):m,i] <- NA } } return(lhs) } lhs/vignettes/0000755000176200001440000000000013425401602013045 5ustar liggesuserslhs/vignettes/lhs_faq.Rmd0000644000176200001440000002377213420502241015135 0ustar liggesusers--- title: "Latin Hypercube Samples - Questions" author: "Rob Carnell" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Latin Hypercube Samples - Questions} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) require(lhs) ``` ## Question 1 I am looking for a package which gives me latin hyper cube samples from a grid of values: ```{r q1} a <- (1:10) b <- (20:30) dataGrid <- expand.grid(a, b) ``` ### Answer The `lhs` package returns a uniformly distributed stratified sample from the unit hypercube. The marginal distributions can then be transformed to your distribution of choice. If you wanted a uniform Latin hypercube on [1,10] and [20,30] with 22 samples, you could do: ```{r a1} X <- randomLHS(22, 2) X[,1] <- 1 + 9*X[,1] X[,2] <- 20 + 10*X[,2] # OR Y <- randomLHS(22, 2) Y[,1] <- qunif(Y[,1], 1, 9) Y[,2] <- qunif(Y[,2], 20, 30) head(X) head(Y) ``` If you want integers only in the sample, then we must be careful about what we mean by a Latin hypercube sample. If you wanted exactly 3 points, then you could divide up the range [1,10] into three almost equal parts and sample from `1:3`, `4:6`, and `7:10`. The problem is that it wouldn't be uniform sample across the range. (7 would be sampled less often than 2 for example) To do a Latin hypercube sample on the intgers, you should have a number of integers on the margins which have the number of points sampled as a common factor. For example if you sample 3 points from `1:9`, and `21:32` then you could sample as follows: ```{r a12} a <- c(sample(1:3,1), sample(4:6, 1), sample(7:9, 1)) b <- c(sample(21:24,1), sample(25:28, 1), sample(29:32,1)) ``` and then randomly permute the entries of `a` and `b`. Or more generally, take `n` samples from the list of integer groups: ```{r a13} integerLHS <- function(n, intGroups) { stopifnot(all(lapply(intGroups, function(X) length(X) %% n) == 0)) stopifnot(require(lhs)) stopifnot(is.list(intGroups)) ranges <- lapply(intGroups, function(X) max(X) - min(X)) A <- matrix(nrow = n, ncol = length(intGroups)) for (j in 1:length(ranges)) { sequ <- order(runif(n)) if (length(intGroups[[1]]) > 1) { spacing <- intGroups[[j]][2] - intGroups[[j]][1] } else stop("must have more than 1 intGroup") for (k in 1:n) { i <- sequ[k] a <- min(intGroups[[j]]) + (i - 1)*(ranges[[j]] + spacing)/n b <- min(intGroups[[j]]) + i*(ranges[[j]] + spacing)/n - 1 if (a < b) { A[k,j] <- sample(seq(a,b,spacing), 1) } else if (a == b) { A[k,j] <- a } else stop("error") } } return(A) } integerLHS(10, list(1:10, 31:40)) integerLHS(5, list(1:10, 31:40)) integerLHS(2, list(1:10, 31:40)) integerLHS(5, list(1:20, 31:60, 101:115)) integerLHS(5, list(seq(2,20,2), 31:60, 101:115)) ``` ## Question 2 I am trying to do a Latin Hypercube Sampling (LHS) to a 5-parameter design matrix. I want the combination of the first three parameters to sum up to 1 (which obviously do not) If I divide each of these parameters with the sum, the uniform distribution is lost. Is there a way to maintain the random LHS (with uniformly distributed parameters) so that the refered condition is fulfilled? ### Answer In my experience with Latin hypercube samples, most people draw the sample on a uniform hypercube and then transform the uniform cube to have new distributions on the margins. The transformed distributions are not necessarily uniform. It is possible to draw a Latin hypercube with correlated margins and I hope to add that to my package in the future. I have also done transforms such that the transformed marginal distributions are correlated (as you have in your example). I have not seen a correlated set of uniform marginal distributions such that the margins sum to one, however. I'll make a quick example argument that explains the difficulty... In two dimensions, you could draw this which is uniform and correlated. ```{r a21} x <- seq(0.05, 0.95, length = 10) y <- 1 - x all.equal(x + y, rep(1, length(x))) hist(x, main = "") hist(y, main = "") ``` But in three dimensions, it is hard to maintain uniformity because large samples on the first uniform margin overweight the small samples on the other margins. ```{r a22} x <- seq(0.05, 0.95, length = 10) y <- runif(length(x), 0, 1 - x) z <- 1 - x - y hist(x, main = "") hist(y, main = "") hist(z, main = "") ``` The commmon practice in your situation is draw the `K` parameters together as a uniform Latin hypercube on `0-1` and then transform the margins of the hypercube to the desired distributions. Easy Example * Parameter 1: normal(1, 2) * Parameter 2: normal(3, 4) * Parameter 3: uniform(5, 10) ```{r a3, fig.width=5, fig.height=5} N <- 1000 x <- randomLHS(N, 3) y <- x y[,1] <- qnorm(x[,1], 1, 2) y[,2] <- qnorm(x[,2], 3, 4) y[,3] <- qunif(x[,3], 5, 10) par(mfrow = c(2,2)) dummy <- apply(x, 2, hist, main = "") par(mfrow = c(2,2)) dummy <- apply(y, 2, hist, main = "") ``` The transformed distributions maintain their "Latin" properties, but are in the form of new distributions. In your case, you'd like the first three columns to be transformed into a correlated set that sums to one. Still follow the pattern... ```{r a24, fig.width=5, fig.height=5} x <- randomLHS(N, 5) y <- x y[,1] <- x[,1]/rowSums(x[,1:3]) y[,2] <- x[,2]/rowSums(x[,1:3]) y[,3] <- x[,3]/rowSums(x[,1:3]) y[,4] <- x[,4] y[,5] <- x[,5] par(mfrow = c(2,3)) dummy <- apply(x, 2, hist, main = "") par(mfrow = c(2,3)) dummy <- apply(y, 2, hist, main = "") all.equal(rowSums(y[,1:3]), rep(1, nrow(y))) ``` The uniform properties are gone as you can see here... ```{r a25} par(mfrow = c(1,1)) pairs(x) pairs(y, col = "red") ``` But, the "Latin" properties of the first three margins are maintained as in this smaller example... ```{r a26} N <- 10 x <- randomLHS(N, 5) y <- x y[,1] <- x[,1]/rowSums(x[,1:3]) y[,2] <- x[,2]/rowSums(x[,1:3]) y[,3] <- x[,3]/rowSums(x[,1:3]) y[,4] <- x[,4] y[,5] <- x[,5] pairs(x) pairs(y, col = "red") ``` ## Question 3 How do I create a Latin hypercube that ranges between between 0 and 1 and sums to 1? ### Answer I have an imperfect solution to this problem using a Dirichlet distribution. The Dirichlet seems to keep the range of the values larger once they are normalized. The result is not uniformly distributed on (0,1) anymore, but instead is Dirichlet distributed with the parameters alpha. The Latin properties are maintained. ```{r qdirichlet} qdirichlet <- function(X, alpha) { # qdirichlet is not an exact quantile function since the quantile of a # multivariate distribtion is not unique # qdirichlet is also not the quantiles of the marginal distributions since # those quantiles do not sum to one # qdirichlet is the quantile of the underlying gamma functions, normalized # This has been tested to show that qdirichlet approximates the dirichlet # distribution well and creates the correct marginal means and variances # when using a latin hypercube sample lena <- length(alpha) stopifnot(is.matrix(X)) sims <- dim(X)[1] stopifnot(dim(X)[2] == lena) if (any(is.na(alpha)) || any(is.na(X))) stop("NA values not allowed in qdirichlet") Y <- matrix(0, nrow = sims, ncol = lena) ind <- which(alpha != 0) for (i in ind) { Y[,i] <- qgamma(X[,i], alpha[i], 1) } Y <- Y / rowSums(Y) return(Y) } X <- randomLHS(1000, 7) Y <- qdirichlet(X, rep(1,7)) stopifnot(all(abs(rowSums(Y) - 1) < 1E-12)) range(Y) ws <- randomLHS(1000, 7) wsSums <- rowSums(ws) wss <- ws / wsSums stopifnot(all(abs(rowSums(wss) - 1) < 1E-12)) range(wss) ``` ## Question 5 I need to use Latin hypercube sampling for my own custome functions. ### Answer ```{r custom, fig.width=5, fig.height=5} require(lhs) # functions you described T1 <- function(t) t*t WL1 <- function(T1, t) T1*t BE1 <- function(WL1, T1, t) WL1*T1*t # t is distributed according to some pdf (e.g. normal) # draw a lhs with 512 rows and 3 columns (one for each function) y <- randomLHS(512, 3) # transform the three columns to a normal distribution (these could be any # distribution) t <- apply(y, 2, function(columny) qnorm(columny, 2, 1)) # transform t using the functions provided result <- cbind( T1(t[,1]), WL1(T1(t[,2]), t[,2]), BE1(WL1(T1(t[,3]), t[,3]), T1(t[,3]), t[,3]) ) # check the results # these should be approximately uniform par(mfrow = c(2,2)) dummy <- apply(y, 2, hist, breaks = 50, main = "") # these should be approximately normal par(mfrow = c(2,2)) dummy <- apply(t, 2, hist, breaks = 50, main = "") # these should be the results of the functions par(mfrow = c(2,2)) dummy <- apply(result, 2, hist, breaks = 50, main = "") ``` ## Question 6 I need a Latin hypercube sample on an integer set or a set of colors. ### Answer ```{r q6, fig.height=5, fig.width=5} N <- 1000 set.seed(1919) x <- randomLHS(N, 4) y <- x # uniform on 1-10 y[,1] <- ceiling(qunif(x[,1], 0, 10)) # three colors 1,2,3 y[,2] <- ceiling(qunif(x[,2], 0, 3)) # other distributions y[,3] <- qunif(x[,3], 5, 10) y[,4] <- qnorm(x[,4], 0, 2) par(mfrow=c(2,2)) dummy <- apply(x, 2, hist, main="") par(mfrow=c(2,2)) plot(1:10, c(table(y[,1])), type="h", col="blue", lwd=2, ylim=c(0,120), ylab="Frequency", xlab="y[,1]") plot(1:3, c(table(y[,2])), type="h", col="blue", lwd=2, ylim=c(0,400), ylab="Frequency", xlab="y[,2]") hist(y[,3], main="") hist(y[,4], main="") # change to color names z <- as.data.frame(y) z[,2] <- factor(y[,2], labels=c("R","G","B")) z[1:10,] ``` lhs/vignettes/augment_lhs.Rmd0000644000176200001440000001442713416532121016030 0ustar liggesusers--- title: "An Example of Augmenting a Latin Hypercube" author: "Rob Carnell" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{An Example of Augmenting a Latin Hypercube} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} %\VignetteAuthor{Rob Carnell} %\VignetteKeyword{lhs} %\VignetteKeyword{latin hypercube} %\VignetteKeyword{augment} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) source("VignetteCommonCode.R") require(lhs) graph2DaugmentLHS1 <- function(sims, extras) { A <- randomLHS(sims, 2) B <- augmentLHS(A, extras) plot.default(A[,1], A[,2], type = "n", ylim = c(0,1), xlim = c(0,1), xlab = "x1", ylab = "x2", xaxs = "i", yaxs = "i", main = "") for (i in 1:length(A[,1])) { rect(floor(A[i,1]*sims)/sims, floor(A[i,2]*sims)/sims, ceiling(A[i,1]*sims)/sims, ceiling(A[i,2]*sims)/sims, col = "grey") } points(A[,1], A[,2], pch = 19, col = "red") abline(v = (0:sims)/sims, h = (0:sims)/sims) return(list(A = A, B = B, sims = sims, extras = extras)) } graph2DaugmentLHS2 <- function(X) { A <- X$A B <- X$B sims <- X$sims extras <- X$extras plot.default(A[,1], A[,2], type = "n", ylim = c(0,1), xlim = c(0,1), xlab = "x1", ylab = "x2", xaxs = "i", yaxs = "i", main = "") N <- sims + extras for (i in 1:length(B[,1])) { rect(floor(B[i,1]*N)/N, floor(B[i,2]*N)/N, ceiling(B[i,1]*N)/N, ceiling(B[i,2]*N)/N, col = "grey") } points(A[,1], A[,2], pch = 19, col = "red") points(B[((sims + 1):(sims + extras)), 1], B[((sims + 1):(sims + extras)), 2], pch = 19, col = "blue") abline(v = (0:N)/N, h = (0:N)/N) } # X <- graph2DaugmentLHS1(5,5) # graph2DaugmentLHS2(X) ``` Suppose that a computer simulation study is being designed that requires expensive runs. A Latin hypercube design is desired for this simulation so that the expectation of the simulation output can be estimated efficiently given the distributions of the input variables. Latin hypercubes are most often used in highly dimensional problems, but the example shown is of small dimension. Suppose further that the total extent of funding is uncertain. Enough money is available for 5 runs, and there is a chance that there will be enough for 5 more. However, if the money for the additional 5 runs does not materialize, then the first 5 runs must be a Latin hypercube alone. A design for this situation can be created using the `lhs` package. First create a random Latin hypercube using the `randomLHS(n, k)` command: ```{r randomlhs} A <- randomLHS(5,2) ``` An example of this hypercube is shown in `r registerFigure("X")`. Note that the *Latin* property of the hypercube requires that each of the 5 equal probability intervals be filled (i.e. each row and each column is filled with one point). Also notice that the exact location of the design point is randomly sampled from within that cell using a uniform distribution for each marginal variable. ----- `r addFigureCaption("X", "A randomly produced Latin Hypercube with uniform marginal distributions for 2 parameters with 5 simulations", register=FALSE)` ```{r original5, echo=FALSE, fig.align='center', fig.height=5, fig.width=5} set.seed(10) X <- graph2DaugmentLHS1(5, 5) ``` ----- Next, in order to augment the design with more points use `augmentLHS(lhs, m)`. The following will add 5 more points to the design: ```{r augment5} B <- augmentLHS(A, 5) ``` The `augmentLHS` function works by re-dividing the original design into `n+m` intervals (e.g. 5+5=10) keeping the original design points exactly in the same position. It then randomly fills the empty row-column sets. The results are shown in `r registerFigure("Y")`. ----- `r addFigureCaption("Y", "A randomly produced Latin Hypercube of 5 points (red) with 5 augmented points (blue). Each parameter has a uniform marginal distribution.", register=FALSE)` ```{r augmented10, fig.align='center', echo=FALSE, fig.height=5, fig.width=5} graph2DaugmentLHS2(X) ``` ----- The `augmentLHS` function uses the following algorithm (see the documentation for `augmentLHS`): * Create a new `(n+m)` by `k` matrix to hold the candidate points after the design has been re-partitioned into `(n+m)^2` cells, where `n` is number of points in the original `lhs` matrix. * Then randomly sweep through each column (1...`k`) in the repartitioned design to find the missing cells. * For each column (variable), randomly search for an empty row, generate a random value that fits in that row, record the value in the new matrix. The new matrix can contain more than `m` points unless `m = 2n`, in which case the new matrix will contain exactly `m` filled rows. * Finally, keep only the first `m` rows of the new matrix. It is guaranteed that there will be `m` full rows (points) in the new matrix. The deleted rows are partially full. The additional candidate points are selected randomly because of the random search used to find empty cells. Also notice that because the original points are randomly placed within the cells, depending on how you bin the marginal distributions, a histogram (of x1 for example) will not necessarily be exactly uniform. Now, the augmenting points do not necessarily form a Latin Hypercube themselves. The original design and augmenting points may form a Latin Hypercube, or there may be more than one point per row in the augmented design. If the augmented points are equal to the number of original points, then a strictly uniform Latin hypercube is guaranteed. An example of an augmented design which is not uniform in the marginal distributions is given in `r registerFigure("Z")` and `r registerFigure("W")`. The commands were: ```{r random_and_augment} A <- randomLHS(7, 2) B <- augmentLHS(A, 3) ``` ----- `r addFigureCaption("Z", "Original design with 7 points", register=FALSE)` ```{r Z, echo=FALSE, fig.align='center', fig.height=5, fig.width=5} set.seed(12) X <- graph2DaugmentLHS1(7, 3) ``` ----- `r addFigureCaption("W", "Augmented design with 3 additional points. Note that row 9 has 2 points and row 3 has none.", register=FALSE)` ```{r W, echo=FALSE, fig.align='center', fig.height=5, fig.width=5} graph2DaugmentLHS2(X) ``` lhs/vignettes/VignetteCommonCode.R0000644000176200001440000000742413413303401016723 0ustar liggesusers# short set of utilities to handle figure and Table naming in .Rmd files numEnv <- new.env() assign("figureList", list(), envir=numEnv) assign("tableList", list(), envir=numEnv) ################################## registerObject <- function(idName, objectListName) { # get the figure list since we can't just add a list element using assign objectListLocal <- get(objectListName, envir=numEnv) # if the idName is already used, error if (!is.null(eval(parse(text=paste("objectListLocal$", idName, sep=""))))) { stop(paste("idName already used prior to registerObject", idName)) } # the new number is the old number of figures plus one num <- length(objectListLocal) + 1 # assign to the local figure list eval(parse(text=paste("objectListLocal$", idName, " <- ", num, sep=""))) # put the local figure list in the one contained in the environment assign(objectListName, objectListLocal, pos=numEnv) return(getObjectLink(idName, objectListName)) } registerTable <- function(idName) { registerObject(idName, "tableList") } registerFigure <- function(idName) { registerObject(idName, "figureList") } getObjectCaption <- function(idName, objectListName) { num <- getObjectNum(idName, objectListName) if (objectListName == "figureList") { return(paste("Figure", num)) } else if (objectListName == "tableList") { return(paste("Table", num)) } else { stop(paste("objectListName:", objectListName, "not recognized")) } } getTableCaption <- function(idName) { getObjectCaption(idName, "tableList") } getFigureCaption <- function(idName) { getObjectCaption(idName, "figureList") } getObjectLink <- function(idName, objectListName) { num <- getObjectNum(idName, objectListName) if (objectListName == "figureList") { return(paste("Figure ", num, "", sep="")) } else if (objectListName == "tableList") { return(paste("Table ", num, "", sep="")) } else { stop(paste("objectListName:", objectListName, "not recognized")) } } getTableLink <- function(idName) { return(getObjectLink(idName, "tableList")) } getFigureLink <- function(idName) { getObjectLink(idName, "figureList") } getObjectNum <- function(idName, objectListName) { objectListLocal <- get(objectListName, envir=numEnv) num <- eval(parse(text=paste("objectListLocal$", idName, sep=""))) if (is.null(num)) { stop(paste("idName is not registered for", idName, "in", objectListName)) } return(num) } getTableNum <- function(idName) { return(getObjectNum(idName, "tableList")) } getFigureNum <- function(idName) { getObjectNum(idName, "figureList") } addTableCaption <- function(idName, caption, register=FALSE) { cap <- ifelse(register, registerTable(idName), getTableCaption(idName)) paste("
", cap, ". ", caption, "
", sep="") } addFigureCaption <- function(idName, caption, register=FALSE) { cap <- ifelse(register, registerFigure(idName), getFigureCaption(idName)) paste("
", cap, ". ", caption, "
", sep="") } ######################### if (FALSE) { registerFigure("X") getFigureCaption("X") getFigureLink("X") getFigureNum("X") getFigureNum("Y") # error registerFigure("Y") getFigureCaption("Y") getFigureLink("Y") getFigureNum("Y") registerFigure("Y") # error registerTable("X") getTableCaption("X") getTableLink("X") getTableNum("X") getTableNum("Y") # error registerTable("Y") getTableCaption("Y") getTableLink("Y") getTableNum("Y") registerTable("Y") #error } lhs/vignettes/lhs_basics.Rmd0000644000176200001440000001717213416533265015646 0ustar liggesusers--- title: "Basic Latin hypercube samples and designs with package lhs" author: "Rob Carnell" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Basic Latin hypercube samples and designs with package lhs} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} %\VignetteAuthor{Rob Carnell} %\VignetteKeyword{lhs} %\VignetteKeyword{latin hypercube} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) require(lhs) source("VignetteCommonCode.R") graph2dLHS <- function(Alhs) { stopifnot(ncol(Alhs) == 2) sims <- nrow(Alhs) par(mar = c(4,4,2,2)) plot.default(Alhs[,1], Alhs[,2], type = "n", ylim = c(0,1), xlim = c(0,1), xlab = "Parameter 1", ylab = "Parameter 2", xaxs = "i", yaxs = "i", main = "") for (i in 1:nrow(Alhs)) { rect(floor(Alhs[i,1]*sims)/sims, floor(Alhs[i,2]*sims)/sims, ceiling(Alhs[i,1]*sims)/sims, ceiling(Alhs[i,2]*sims)/sims, col = "grey") } points(Alhs[,1], Alhs[,2], pch = 19, col = "red") abline(v = (0:sims)/sims, h = (0:sims)/sims) } # transform is a function of the kind that takes a number # transform <- function(x){return(qnorm(x,mean=0, std=1))} graph2dLHSTransform <- function(Alhs, transform1, transform2, min1, max1, min2, max2) { stopifnot(ncol(Alhs) == 2) stopifnot(all(Alhs[,1] <= max1 && Alhs[,1] >= min1)) stopifnot(all(Alhs[,2] <= max2 && Alhs[,2] >= min2)) sims <- nrow(Alhs) breaks <- seq(0,1,length = sims + 1)[2:(sims)] breaksTransformed1 <- sapply(breaks, transform1) breaksTransformed2 <- sapply(breaks, transform2) par(mar = c(4,4,2,2)) plot.default(Alhs[,1], Alhs[,2], type = "n", ylim = c(min2, max2), xlim = c(min1, max1), xlab = "Parameter 1", ylab = "Parameter 2", xaxs = "i", yaxs = "i", main = "") for (si in 1:sims) { temp <- Alhs[si,] for (i in 1:sims) { if ((i == 1 && min1 <= temp[1] && breaksTransformed1[i] >= temp[1]) || (i == sims && max1 >= temp[1] && breaksTransformed1[i - 1] <= temp[1]) || (breaksTransformed1[i - 1] <= temp[1] && breaksTransformed1[i] >= temp[1])) { for (j in 1:sims) { if ((j == 1 && min2 <= temp[2] && breaksTransformed2[j] >= temp[2]) || (j == sims && max2 >= temp[2] && breaksTransformed2[j - 1] <= temp[2]) || (breaksTransformed2[j - 1] <= temp[2] && breaksTransformed2[j] >= temp[2])) { if (i == 1) { xbot <- min1 xtop <- breaksTransformed1[i] } else if (i == sims) { xbot <- breaksTransformed1[i - 1] xtop <- max1 } else { xbot <- breaksTransformed1[i - 1] xtop <- breaksTransformed1[i] } if (j == 1) { ybot <- min2 ytop <- breaksTransformed2[j] } else if (j == sims) { ybot <- breaksTransformed2[j - 1] ytop <- max2 } else { ybot <- breaksTransformed2[j - 1] ytop <- breaksTransformed2[j] } rect(xbot, ybot, xtop, ytop, col = "grey") } } } } } points(Alhs[,1], Alhs[,2], pch = 19, col = "red") abline(v = breaksTransformed1, h = breaksTransformed2) } #set.seed(1111) #A <- randomLHS(5,4) #f <- function(x){qnorm(x)} #g <- function(x){qlnorm(x, meanlog=0.5, sdlog=1)} #B <- A #B[,1] <- f(A[,1]) #B[,2] <- g(A[,2]) #graph2dLHSTransform(B[,1:2], f, g, -4, 4, 0, 8) #f <- function(x){qunif(x, 3, 5)} #B <- apply(A, 2, f) #graph2dLHSTransform(B[,1:2], f) ``` ### Theory of Latin Hypercube Sampling For the technical basis of Latin Hypercube Sampling (LHS) and Latin Hypercube Designs (LHD) please see: * Stein, Michael. _Large Sample Properties of Simulations Using Latin Hypercube Sampling_ Technometrics, Vol 28, No 2, 1987. * McKay, MD, et.al. _A Comparison of Three Methods for Selecting Values of Input Variables in the Analysis of Output from a Computer Code_ Technometrics, Vol 21, No 2, 1979. This package was created to bring these designs to R and to implement many of the articles that followed on optimized sampling methods. ### Create a Simple LHS Basic LHS's are created using `randomLHS`. ```{r block1} # set the seed for reproducibility set.seed(1111) # a design with 5 samples from 4 parameters A <- randomLHS(5, 4) A ``` In general, the LHS is uniform on the margins until transformed (`r registerFigure("X")`): `r addFigureCaption("X", "Two dimensions of a Uniform random LHS with 5 samples", register=FALSE)` ```{r figureX, fig.align='center', fig.height=5, fig.width=5, echo=FALSE} graph2dLHS(A[,1:2]) ``` It is common to transform the margins of the design (the columns) into other distributions (`r registerFigure("Y")`) ```{r block 3} B <- matrix(nrow = nrow(A), ncol = ncol(A)) B[,1] <- qnorm(A[,1], mean = 0, sd = 1) B[,2] <- qlnorm(A[,2], meanlog = 0.5, sdlog = 1) B[,3] <- A[,3] B[,4] <- qunif(A[,4], min = 7, max = 10) B ``` `r addFigureCaption("Y", "Two dimensions of a transformed random LHS with 5 samples", register=FALSE)` ```{r figureY, fig.align='center', fig.height=5, fig.width=5, echo=FALSE} f <- function(x){qnorm(x)} g <- function(x){qlnorm(x, meanlog = 0.5, sdlog = 1)} graph2dLHSTransform(B[,1:2], f, g, -4, 4, 0, 8) ``` ### Optimizing the Design The LHS can be optimized using a number of methods in the `lhs` package. Each method attempts to improve on the random design by ensuring that the selected points are as uncorrelated and space filling as possible. `r registerTable("tab1")` shows some results. `r registerFigure("Z")`, `r registerFigure("W")`, and `r registerFigure("G")` show corresponding plots. ```{r block 4} set.seed(101) A <- randomLHS(30, 10) A1 <- optimumLHS(30, 10, maxSweeps = 4, eps = 0.01) A2 <- maximinLHS(30, 10, dup = 5) A3 <- improvedLHS(30, 10, dup = 5) A4 <- geneticLHS(30, 10, pop = 1000, gen = 8, pMut = 0.1, criterium = "S") A5 <- geneticLHS(30, 10, pop = 1000, gen = 8, pMut = 0.1, criterium = "Maximin") ``` ----- `r addTableCaption("tab1", "Sample results and metrics of various LHS algorithms", register=FALSE)` Method | Min Distance btwn pts | Mean Distance btwn pts | Max Correlation btwn pts :-----|:-----:|:-----:|:-----: randomLHS | `r min(dist(A))` | `r mean(dist(A))` | `r max(abs(cor(A)-diag(10)))` optimumLHS | `r min(dist(A1))` | `r mean(dist(A1))` | `r max(abs(cor(A1)-diag(10)))` maximinLHS | `r min(dist(A2))` | `r mean(dist(A2))` | `r max(abs(cor(A2)-diag(10)))` improvedLHS | `r min(dist(A3))` | `r mean(dist(A3))` | `r max(abs(cor(A3)-diag(10)))` geneticLHS (S) | `r min(dist(A4))` | `r mean(dist(A4))` | `r max(abs(cor(A4)-diag(10)))` geneticLHS (Maximin) | `r min(dist(A5))` | `r mean(dist(A5))` | `r max(abs(cor(A5)-diag(10)))` ----- `r addFigureCaption("Z", "Pairwise margins of a randomLHS", register=FALSE)` ```{r Z, fig.align='center', fig.height=7, fig.width=7, echo=FALSE} pairs(A, pch = 19, col = "blue", cex = 0.5) ``` ----- `r addFigureCaption("W", "Pairwise margins of a optimumLHS", register=FALSE)` ```{r W, fig.align='center', fig.height=7, fig.width=7, echo=FALSE} pairs(A1, pch = 19, col = "blue", cex = 0.5) ``` ----- `r addFigureCaption("G", "Pairwise margins of a maximinLHS", register=FALSE)` ```{r G, fig.align='center', fig.height=7, fig.width=7, echo=FALSE} pairs(A2, pch = 19, col = "blue", cex = 0.5) ``` lhs/README.md0000644000176200001440000000556713423725053012340 0ustar liggesusers# lhs This package provides a number of methods for creating and augmenting Latin Hypercube Samples |Linux & MacOS|Windows|Code Coverage|CRAN Downloads|CRAN| |:---:|:---:|:---:|:---:|:---:| |[![Build Status](https://travis-ci.org/bertcarnell/lhs.svg?branch=master)](https://travis-ci.org/bertcarnell/lhs)|[![Build status](https://ci.appveyor.com/api/projects/status/5h8gjnq6a30r8y37/branch/master?svg=true)](https://ci.appveyor.com/project/bertcarnell/lhs/branch/master)|[![Coverage status](https://codecov.io/gh/bertcarnell/lhs/branch/master/graph/badge.svg)](https://codecov.io/github/bertcarnell/lhs?branch=master)|[![](https://cranlogs.r-pkg.org/badges/lhs)](https://cran.r-project.org/package=lhs)|[![CRAN status](https://www.r-pkg.org/badges/version/lhs)](https://cran.r-project.org/package=lhs)| Visit the webpage [here](https://bertcarnell.github.io/lhs/) See the Doxygen documentation [here](https://bertcarnell.github.io/lhs/html/index.html) ## Installation You can install the released version of `lhs` from [CRAN](https://CRAN.R-project.org) with: ``` r install.packages("lhs") ``` You can also install the development version of `lhs` from here with: ``` r # (if not done already:) install.packages("devtools") devtools::install_github("bertcarnell/lhs") ``` ## Example Create a random LHS with 10 samples and 3 variables ``` r X <- randomLHS(10, 3) ``` ## Development The reverse dependency checks for lhs can be found [here](etc/README.md). ## Help R-Help Examples of using the LHS package - [Latin hyper cube sampling from expand.grid()](http://r.789695.n4.nabble.com/R-Latin-hyper-cube-sampling-from-expand-grid-tp816493.html) - [Latin Hypercube Sampling with a condition](http://r.789695.n4.nabble.com/Latin-Hypercube-Sampling-with-a-condition-tp3563765.html) - [Latin Hypercube with condition sum = 1](http://r.789695.n4.nabble.com/Latin-Hypercube-with-condition-sum-1-tp875487.html) - [Latin hypercube sampling](http://r.789695.n4.nabble.com/latin-hypercube-sampling-tp4659028.html) - [Latin Hypercube Sample and transformation to uniformly distributed integers or classes](http://r.789695.n4.nabble.com/Latin-Hypercube-Sample-and-transformation-to-uniformly-distributed-integers-or-classes-tp4677804.html) - [Latin hypercube sampling from a non-uniform distribution](http://r.789695.n4.nabble.com/Latin-hypercube-sampling-from-a-non-uniform-distribution-tp4743686.html) - [Latin Hypercube Sampling when parameters are defined according to specific probability distributions](http://r.789695.n4.nabble.com/Latin-Hypercube-Sampling-when-parameters-are-defined-according-to-specific-probability-distributions-tp4734710.html) ## Other lhs package announcement: [R-pkgs New R-Packages: Triangle and LHS](http://r.789695.n4.nabble.com/R-pkgs-New-R-Packages-Triangle-and-LHS-tp803930.html) lhs/MD50000644000176200001440000001406313425544676011374 0ustar liggesusers738f26a74cf97821c09d33e2bb30df91 *ChangeLog 8a1b28d487d78052a33a92b190bacd24 *DESCRIPTION 09849b84cffd7b50d2ae4ddbc4a915c7 *NAMESPACE 53866b3921acf88d621f1b67d6bf5517 *R/augmentLHS.R b6e530ac83909100d41f0969cc7d1322 *R/createOA.R e0aa8aefc35430288bf424573158dcfb *R/create_oalhs.R ee054a9159cb67016025e58156c55044 *R/geneticLHS.R f5e1089e117a72ae7a5e80e436fa301c *R/improvedLHS.r b9c800f8a568155f058dbf1f23732533 *R/lhs.R bc7ff69df40838eff08c3dc2f6c56a58 *R/maximinLHS.R 365d59c706b63480a2cf5e090425d5bc *R/oa_to_oalhs.R 6ba4bc2876c5d5f1b2ae33186299aa6f *R/optAugmentLHS.R d3569b956d2f4c5e30ac0e9284416c5e *R/optSeededLHS.R b6508e5d04a13558e19c6534c768e2a9 *R/optimumLHS.R 28fe6e3db4a011dd782118c1574ceb9d *R/randomLHS.r fa76f73d2e3720e44ec4d32f602c5158 *R/runifint.r 413d61d7527671bda9b6d1853d7baf1a *README.md 2bf6f44bcf72f9977edc4b52164a01fe *build/vignette.rds 9b2d0479bd6fdc50111633fbd31de830 *inst/doc/augment_lhs.R 2ea4584a4f8f5710e9e845e365d054ea *inst/doc/augment_lhs.Rmd c84947251c896bccefd466b2068ab5f6 *inst/doc/augment_lhs.html 706acf5aad54a39138366be9d8039074 *inst/doc/lhs_basics.R 8ff53a64234bb3915981edd70e797c53 *inst/doc/lhs_basics.Rmd 5a23eb5c2173dae27c03b201b3c72ecb *inst/doc/lhs_basics.html 3b6211e7f08ef193fa8e5e4f20c1464e *inst/doc/lhs_faq.R 2620f0f05e0944b9be10d762959e9f79 *inst/doc/lhs_faq.Rmd d7c56d6a85633206718d822b9533ae2e *inst/doc/lhs_faq.html 385a89b5cd29ef880745c295821f72fa *man/augmentLHS.Rd 40623f2107c09ccc9e37b813ffc1b548 *man/createAddelKemp.Rd 59013d1afc18cdd68708d539112dd29a *man/createAddelKemp3.Rd acc97726093658f60e54403d6e82ba02 *man/createAddelKempN.Rd 6b3664749a847f9307cb2086c36b031b *man/createBose.Rd 3132b33037b68dd144ec719f872e348c *man/createBoseBush.Rd c270dbdb220db7633c940295956284ec *man/createBoseBushl.Rd f9af8dee828ac0bc69b14848a5a41258 *man/createBush.Rd 9d79b1acf149f01f6de61bed625779c0 *man/createBusht.Rd 6099e0cdab76518961760e5b7ba376bb *man/create_oalhs.Rd fd4a49b999abf0313b10a35bae672549 *man/geneticLHS.Rd 33236f7b04b9e418590f3932f99951a6 *man/improvedLHS.Rd ab1c8e371d2300cc74522fefaca5b874 *man/lhs-package.Rd ef21075d9bb38a4900a85757a913abe2 *man/maximinLHS.Rd 602d1ee855b5e630920fb4f2c986ba33 *man/oa_to_oalhs.Rd 66532d58bedf1bb20bb8d3438b467266 *man/optAugmentLHS.Rd b1a926d6b047900a3f881baae6b4f354 *man/optSeededLHS.Rd 8cd2ec8b34b05aba095b63fe01b2a0ed *man/optimumLHS.Rd a159b822a2135b86a0f29ab62fbb8a74 *man/randomLHS.Rd 9a19134f12bca56dd6971340aac485d4 *man/runifint.Rd 1b506b82759970473e6f3168130d457f *src/COrthogonalArray.cpp bf93f4b1105f049176e25303bee2bc71 *src/COrthogonalArray.h 0cc862de831d9d7cfc565914f131cd9b *src/CRandom.h 5e0cbc7b59a6c1a7a1cb3512b16f1bf0 *src/LHSCommonDefines.h 4cae5cc117ded747a7944e5f936067bb *src/Makevars 4cae5cc117ded747a7944e5f936067bb *src/Makevars.win 9ffad9bbee1aa365b1bddca329bca9be *src/OACommonDefines.h dd1ee7c05925ea002a3177907d472373 *src/RStandardUniform.h 245e20c41808deacb9409ad9e66572ee *src/ak.h f9d7d20824d92d4322b4b4084192d001 *src/ak3.cpp 3b8e4ffebef28b968b49e12876d211bd *src/akconst.cpp d14771adb4387199f2dea21d9bd7954b *src/akn.cpp 1d11b431208d8b9483b66a21994641ba *src/construct.cpp 03b71435663d98c97684cd3f861c4ff6 *src/construct.h 218cf359cb567cadb1bb69f2d2327568 *src/galdef.h eb5aa31960cd9e44f637977f458fc83f *src/galois.cpp 14a50cdf713f2ae2a9f9105884a8ea88 *src/galois.h 330a3b1a41ee00e2cf9b8c6a4777c79a *src/geneticLHS.cpp 39080cf4d077cb867af493a4e86942ce *src/gfields.cpp 7f0764736a3c7cb4abd41c41537dde74 *src/improvedLHS.cpp f8a858c303d3387c6836694797545d73 *src/init.c 4bf179eba7cf9a181d4339be93ece5df *src/lhs_r.cpp 34244d71979c0b02707cfc9cba9a16e6 *src/lhs_r.h 112f5c99cef0996cfca96bdeea2fe88f *src/lhs_r_utilities.cpp 79e9b90afac77b5e3bdcf9c51c590c17 *src/lhs_r_utilities.h 3b15500d1cb1c4c204e4b972443f98f2 *src/matrix.h 4bd0167bbcd8fdfe8548affa2b904171 *src/maximinLHS.cpp 342e09723775055017672becaa8f241d *src/oa.cpp d6db5bd4d7a5235f0d3b5ce6b1ed9bf6 *src/oa.h 03e78b20f5310fcd97e848a8b98f0d67 *src/oaLHS.cpp d15f2924b4e06c4ab71b26eb80ff354b *src/oaLHS.h d1cda7556053f456b248283aec96896c *src/oaLHSUtility.h e4a76d42e0de633f82a072ea10df2f4a *src/oa_r.cpp 5ff31abc5a5cff34b84d82d5679d86d3 *src/oa_r.h 2bff89932d7176fecba89b681f3a12bd *src/oa_r_utils.cpp 5267128af97c78e8ceabe3fbffd8c5a2 *src/oa_r_utils.h 4d6b2c775d7fd2ee8b11e70ae4bc14a0 *src/oalhs_r.cpp a6aac0d67ee324863cf8f33be0db0760 *src/oalhs_r.h 4c1bca213858e5b2120cf58031b525d7 *src/optSeededLHS.cpp dd24c4bdc7f50c6c807fbf3b508134af *src/optimumLHS.cpp 0537b1d2d2a33374e68331c1d4580fe7 *src/order.h 8173b691d1f880c7ca063a0f3b0c3245 *src/primes.cpp a7f4d48674874ea01082ee2aa0aca3da *src/primes.h cc0b93085be6180dc324d63de63826db *src/randomLHS.cpp b0f2c82442ed9134bc9ce60b35bf1380 *src/runif.cpp 216768bf36baabae9180b46fe41991e5 *src/runif.h 2a58c2e95481fe9f2d175db2bfc37947 *src/rutils.cpp 2b8d252e65588f0b9def38517819e935 *src/rutils.h 03ce2f1f5e8740c2a64778195eaf952f *src/utilityLHS.cpp cfd576d0692da9e2eca713e649d35fd0 *src/utilityLHS.h 33533702dbc28d2bb4619c27a91c4db6 *src/xtndeclare.h f05fd52b1a6b5b1e3ad3864f3bbff457 *src/xtndispatch.h 8a71e6fd5d2c31f952a389fcfb7cec8d *src/xtnset.h 61a8d6137ec622105090092597f674f1 *tests/testthat.R b8f77002941c44318ccd8c306af0228c *tests/testthat/helper-lhs.R 2c7d56d1b00eda9f385a6ed433dcdc24 *tests/testthat/test-augmentlhs.R fe803b4ea05122c1f33700d69f4a4f42 *tests/testthat/test-create_oalhs.R 6e589431e7d4c5c42707bd6ba8f84488 *tests/testthat/test-createoa.R 15105804ea6ef87a0d84eea60d8f94fd *tests/testthat/test-geneticlhs.R 505ec17330211656bc054d0f057b2968 *tests/testthat/test-improvedlhs.r abe052846c141cde46a81566e8ca5199 *tests/testthat/test-maximinlhs.R 11321200de36a73acabbee6cf2b1da41 *tests/testthat/test-oa_to_oalhs.R 5463fe0a9c89f0f762a89cbd461f57d0 *tests/testthat/test-optaugmentlhs.R f810d8f8b902a3398eb7d300701a4296 *tests/testthat/test-optimumlhs.R e0518a44b176a6478581f36e770c3435 *tests/testthat/test-optseededlhs.R 1f277a74f02297031d0512822fdcd3da *tests/testthat/test-randomlhs.r 8f248fe4625ca971df2ab8b8f503fc6d *vignettes/VignetteCommonCode.R 2ea4584a4f8f5710e9e845e365d054ea *vignettes/augment_lhs.Rmd 8ff53a64234bb3915981edd70e797c53 *vignettes/lhs_basics.Rmd 2620f0f05e0944b9be10d762959e9f79 *vignettes/lhs_faq.Rmd lhs/build/0000755000176200001440000000000013425401600012132 5ustar liggesuserslhs/build/vignette.rds0000644000176200001440000000052413425401600014472 0ustar liggesusersPMO@~"$IAbnۍvKbKrB%&zZ~Pr&,0۳ RwیzMEi9JRFdcȁ8 rHilhs/DESCRIPTION0000644000176200001440000000142613425544676012571 0ustar liggesusersPackage: lhs Title: Latin Hypercube Samples Version: 1.0.1 Authors@R: person(given = "Rob", family = "Carnell", role = c("aut", "cre"), email = "bertcarnell@gmail.com") Description: Provides a number of methods for creating and augmenting Latin Hypercube Samples. License: GPL-3 Encoding: UTF-8 LazyData: true Depends: R (>= 3.4.0) LinkingTo: Rcpp Imports: Rcpp Suggests: testthat, DoE.base, knitr, rmarkdown, covr URL: https://github.com/bertcarnell/lhs BugReports: https://github.com/bertcarnell/lhs/issues RoxygenNote: 6.1.1 VignetteBuilder: knitr NeedsCompilation: yes Packaged: 2019-02-02 20:54:26 UTC; bertc Author: Rob Carnell [aut, cre] Maintainer: Rob Carnell Repository: CRAN Date/Publication: 2019-02-03 11:00:14 UTC lhs/ChangeLog0000644000176200001440000000467213425360762012633 0ustar liggesusersVersion 0.1 Version 0.2 Bug suggested by Bjarne Hansen fixed 7/20/06. Bug involved augmenting lhs samples with one parameter. Example a <- randomLHS(4, 1); augmentLHS(a, 2). RUnit test added to check this bug. All RUnit tests satisfactory. Version 0.3 Another bug reported by Bjarne Hansen on 7/23/06, and fixed on 10/21/06. The bug involved augmenting a hypercube with one point. RUnit test added to check this bug. All RUnit tests satisfactory. Also added documentation consisting of an augmentation example. Added a lhs package help page. Version 0.4 Changed the license to GPL >= 2 according to a Kurt Hornik email Version 0.5 Change output filenames to be portable Version 0.6 Added a new option to randomLHS to allow for similar lhs's when the seed is set and columns are added Version 0.7 Removed test directories to fix them for the proper package structure. Version 0.8 Refactored the underlying C code into C++ to add range checks for internal arrays. Corrected a bug suggested by XXXX on DATE. Corrected the bug suggested by Prof Ripley on DATE with the range checking. Version 0.9 Removed non-portable code introduced in Version 0.8 Version 0.10 Changed static template method definitions to be included in the definition of the utilityLHS class, instead of in the header below the class. Version 0.11 Fixed a bug in the geneticLHS code and added Maximin to the optimization criteria. Fixed a bug caused by a change in R2.3.3 that requires a matrix dimnames to be a list. Added an importFrom to the namespace. Version 0.12 Fixed a bug in the Description file. Version 0.13 Numerical accuracy checks on the Solaris 10 systems was failing. Unable to reproduce this error easily, but it is limited to the numerical accuracy tests. Eliminated the numerical tests for Solaris/Sun/Sparc. Version 0.14 Fixed a bug suggested by Roland Lowe on 8/4/2016. Version 0.15 Added registration of native routines. Version 0.16 Removed the file output of test files which were causing errors on CRAN. changed the version dependency to >= 3.3.0. (>=3.4.0 caused errors on CRAN) Verion 1.0 Major revision. Changed all underlying C code to C++ using Rcpp. Added orthogonal array latin hypercube capability Version 1.0.1 Update to fix a memory leak notice on CRAN servers when checking examples with valgrind lhs/man/0000755000176200001440000000000013417501070011611 5ustar liggesuserslhs/man/createBush.Rd0000644000176200001440000000140713420216024014163 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/createOA.R \name{createBush} \alias{createBush} \title{Create an orthogonal array using the Bush algorithm} \usage{ createBush(q, ncol, bRandom = TRUE) } \arguments{ \item{q}{the number of symbols in the array} \item{ncol}{number of parameters or columns} \item{bRandom}{should the array be randomized} } \value{ an orthogonal array } \description{ Create an orthogonal array using the Bush algorithm } \examples{ A <- createBush(3, 3, FALSE) B <- createBush(4, 5, TRUE) } \seealso{ Other methods to create orthogonal arrays [createBoseBush()], [createBose()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBusht()], [createBoseBushl()] } lhs/man/optimumLHS.Rd0000644000176200001440000000600113425060620014136 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/optimumLHS.R \name{optimumLHS} \alias{optimumLHS} \title{Optimum Latin Hypercube Sample} \usage{ optimumLHS(n = 10, k = 2, maxSweeps = 2, eps = 0.1, verbose = FALSE) } \arguments{ \item{n}{The number of partitions (simulations or design points or rows)} \item{k}{The number of replications (variables or columns)} \item{maxSweeps}{The maximum number of times the CP algorithm is applied to all the columns.} \item{eps}{The optimal stopping criterion. Algorithm stops when the change in optimality measure is less than eps*100\% of the previous value.} \item{verbose}{Print informational messages} } \value{ An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] } \description{ Draws a Latin Hypercube Sample from a set of uniform distributions for use in creating a Latin Hypercube Design. This function uses the Columnwise Pairwise (\acronym{CP}) algorithm to generate an optimal design with respect to the S optimality criterion. } \details{ Latin hypercube sampling (LHS) was developed to generate a distribution of collections of parameter values from a multidimensional distribution. A square grid containing possible sample points is a Latin square iff there is only one sample in each row and each column. A Latin hypercube is the generalisation of this concept to an arbitrary number of dimensions. When sampling a function of \code{k} variables, the range of each variable is divided into \code{n} equally probable intervals. \code{n} sample points are then drawn such that a Latin Hypercube is created. Latin Hypercube sampling generates more efficient estimates of desired parameters than simple Monte Carlo sampling. This program generates a Latin Hypercube Sample by creating random permutations of the first \code{n} integers in each of \code{k} columns and then transforming those integers into n sections of a standard uniform distribution. Random values are then sampled from within each of the n sections. Once the sample is generated, the uniform sample from a column can be transformed to any distribution by using the quantile functions, e.g. qnorm(). Different columns can have different distributions. S-optimality seeks to maximize the mean distance from each design point to all the other points in the design, so the points are as spread out as possible. This function uses the \acronym{CP} algorithm to generate an optimal design with respect to the S optimality criterion. } \examples{ A <- optimumLHS(4, 3, 5, .05) } \references{ Stocki, R. (2005) A method to improve design reliability using optimal Latin hypercube sampling \emph{Computer Assisted Mechanics and Engineering Sciences} \bold{12}, 87--105. } \seealso{ [randomLHS()], [geneticLHS()], [improvedLHS()] and [maximinLHS()] to generate Latin Hypercube Samples. [optAugmentLHS()], [optSeededLHS()], and [augmentLHS()] to modify and augment existing designs. } \keyword{design} lhs/man/createBoseBush.Rd0000644000176200001440000000144113420216024014772 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/createOA.R \name{createBoseBush} \alias{createBoseBush} \title{Create an orthogonal array using the Bose-Bush algorithm} \usage{ createBoseBush(q, ncol, bRandom = TRUE) } \arguments{ \item{q}{the number of symbols in the array} \item{ncol}{number of parameters or columns} \item{bRandom}{should the array be randomized} } \value{ an orthogonal array } \description{ Create an orthogonal array using the Bose-Bush algorithm } \examples{ A <- createBoseBush(4, 3, FALSE) B <- createBoseBush(8, 3, TRUE) } \seealso{ Other methods to create orthogonal arrays [createBush()], [createBose()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBusht()], [createBoseBushl()] } lhs/man/createAddelKemp.Rd0000644000176200001440000000145113420216024015107 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/createOA.R \name{createAddelKemp} \alias{createAddelKemp} \title{Create an orthogonal array using the Addelman-Kempthorne algorithm} \usage{ createAddelKemp(q, ncol, bRandom = TRUE) } \arguments{ \item{q}{the number of symbols in the array} \item{ncol}{number of parameters or columns} \item{bRandom}{should the array be randomized} } \value{ an orthogonal array } \description{ Create an orthogonal array using the Addelman-Kempthorne algorithm } \examples{ A <- createAddelKemp(3, 3, TRUE) B <- createAddelKemp(3, 5, FALSE) } \seealso{ Other methods to create orthogonal arrays [createBoseBush()], [createBose()], [createAddelKemp3()], [createAddelKempN()], [createBusht()], [createBoseBushl()] } lhs/man/createAddelKempN.Rd0000644000176200001440000000164413420216024015231 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/createOA.R \name{createAddelKempN} \alias{createAddelKempN} \title{Create an orthogonal array using the Addelman-Kempthorne algorithm with alternate strength} \usage{ createAddelKempN(q, ncol, exponent, bRandom = TRUE) } \arguments{ \item{q}{the number of symbols in the array} \item{ncol}{number of parameters or columns} \item{exponent}{the exponent on q} \item{bRandom}{should the array be randomized} } \value{ an orthogonal array } \description{ Create an orthogonal array using the Addelman-Kempthorne algorithm with alternate strength } \examples{ A <- createAddelKempN(3, 4, 3, TRUE) B <- createAddelKempN(3, 4, 4, TRUE) } \seealso{ Other methods to create orthogonal arrays [createBoseBush()], [createBose()], [createBush()], [createAddelKemp()], [createAddelKemp3()], [createBusht()], [createBoseBushl()] } lhs/man/createBusht.Rd0000644000176200001440000000165013425060620014353 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/createOA.R \name{createBusht} \alias{createBusht} \title{Create an orthogonal array using the Bush algorithm with alternate strength} \usage{ createBusht(q, ncol, strength, bRandom = TRUE) } \arguments{ \item{q}{the number of symbols in the array} \item{ncol}{number of parameters or columns} \item{strength}{the strength of the array to be created} \item{bRandom}{should the array be randomized} } \value{ an orthogonal array } \description{ Create an orthogonal array using the Bush algorithm with alternate strength } \examples{ set.seed(1234) A <- createBusht(3, 4, 2, TRUE) B <- createBusht(3, 4, 3, FALSE) G <- createBusht(3, 4, 3, TRUE) } \seealso{ Other methods to create orthogonal arrays [createBoseBush()], [createBose()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBoseBushl()] } lhs/man/createBose.Rd0000644000176200001440000000140713420216024014152 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/createOA.R \name{createBose} \alias{createBose} \title{Create an orthogonal array using the Bose algorithm} \usage{ createBose(q, ncol, bRandom = TRUE) } \arguments{ \item{q}{the number of symbols in the array} \item{ncol}{number of parameters or columns} \item{bRandom}{should the array be randomized} } \value{ an orthogonal array } \description{ Create an orthogonal array using the Bose algorithm } \examples{ A <- createBose(3, 3, FALSE) B <- createBose(5, 4, TRUE) } \seealso{ Other methods to create orthogonal arrays [createBush()], [createBoseBush()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBusht()], [createBoseBushl()] } lhs/man/optAugmentLHS.Rd0000644000176200001440000000323113425061507014576 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/optAugmentLHS.R \name{optAugmentLHS} \alias{optAugmentLHS} \title{Optimal Augmented Latin Hypercube Sample} \usage{ optAugmentLHS(lhs, m = 1, mult = 2) } \arguments{ \item{lhs}{The Latin Hypercube Design to which points are to be added} \item{m}{The number of additional points to add to matrix \code{lhs}} \item{mult}{\code{m*mult} random candidate points will be created.} } \value{ An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] } \description{ Augments an existing Latin Hypercube Sample, adding points to the design, while maintaining the \emph{latin} properties of the design. This function attempts to add the points to the design in an optimal way. } \details{ Augments an existing Latin Hypercube Sample, adding points to the design, while maintaining the \emph{latin} properties of the design. This function attempts to add the points to the design in a way that maximizes S optimality. S-optimality seeks to maximize the mean distance from each design point to all the other points in the design, so the points are as spread out as possible. } \examples{ set.seed(1234) a <- randomLHS(4,3) b <- optAugmentLHS(a, 2, 3) } \references{ Stein, M. (1987) Large Sample Properties of Simulations Using Latin Hypercube Sampling. \emph{Technometrics}. \bold{29}, 143--151. } \seealso{ [randomLHS()], [geneticLHS()], [improvedLHS()], [maximinLHS()], and [optimumLHS()] to generate Latin Hypercube Samples. [optSeededLHS()] and [augmentLHS()] to modify and augment existing designs. } \keyword{design} lhs/man/runifint.Rd0000644000176200001440000000077613416402074013753 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/runifint.r \name{runifint} \alias{runifint} \title{Create a Random Sample of Uniform Integers} \usage{ runifint(n = 1, min_int = 0, max_int = 1) } \arguments{ \item{n}{The number of samples} \item{min_int}{the minimum integer \code{x >= min_int}} \item{max_int}{the maximum integer \code{x <= max_int}} } \value{ the sample sample of size \code{n} } \description{ Create a Random Sample of Uniform Integers } lhs/man/lhs-package.Rd0000644000176200001440000000106413422230535014261 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lhs.R \docType{package} \name{lhs-package} \alias{lhs} \alias{lhs-package} \title{lhs: Latin Hypercube Samples} \description{ Provides a number of methods for creating and augmenting Latin Hypercube Samples. } \seealso{ Useful links: \itemize{ \item \url{https://github.com/bertcarnell/lhs} \item Report bugs at \url{https://github.com/bertcarnell/lhs/issues} } } \author{ \strong{Maintainer}: Rob Carnell \email{bertcarnell@gmail.com} } \keyword{internal} lhs/man/createAddelKemp3.Rd0000644000176200001440000000151713420216024015175 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/createOA.R \name{createAddelKemp3} \alias{createAddelKemp3} \title{Create an orthogonal array using the Addelman-Kempthorne algorithm with 2*q^3 rows} \usage{ createAddelKemp3(q, ncol, bRandom = TRUE) } \arguments{ \item{q}{the number of symbols in the array} \item{ncol}{number of parameters or columns} \item{bRandom}{should the array be randomized} } \value{ an orthogonal array } \description{ Create an orthogonal array using the Addelman-Kempthorne algorithm with 2*q^3 rows } \examples{ A <- createAddelKemp3(3, 3, TRUE) B <- createAddelKemp3(3, 5, FALSE) } \seealso{ Other methods to create orthogonal arrays [createBushBush()], [createBose()], [createAddelKemp()], [createAddelKempN()], [createBusht()], [createBoseBushl()] } lhs/man/maximinLHS.Rd0000644000176200001440000000745413425060620014123 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/maximinLHS.R \name{maximinLHS} \alias{maximinLHS} \title{Maximin Latin Hypercube Sample} \usage{ maximinLHS(n, k, method = "build", dup = 1, eps = 0.05, maxIter = 100, optimize.on = "grid", debug = FALSE) } \arguments{ \item{n}{The number of partitions (simulations or design points or rows)} \item{k}{The number of replications (variables or columns)} \item{method}{\code{build} or \code{iterative} is the method of LHS creation. \code{build} finds the next best point while constructing the LHS. \code{iterative} optimizes the resulting sample on [0,1] or sample grid on [1,N]} \item{dup}{A factor that determines the number of candidate points used in the search. A multiple of the number of remaining points than can be added. This is used when \code{method="build"}} \item{eps}{The minimum percent change in the minimum distance used in the \code{iterative} method} \item{maxIter}{The maximum number of iterations to use in the \code{iterative} method} \item{optimize.on}{\code{grid} or \code{result} gives the basis of the optimization. \code{grid} optimizes the LHS on the underlying integer grid. \code{result} optimizes the resulting sample on [0,1]} \item{debug}{prints additional information about the process of the optimization} } \value{ An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] } \description{ Draws a Latin Hypercube Sample from a set of uniform distributions for use in creating a Latin Hypercube Design. This function attempts to optimize the sample by maximizing the minium distance between design points (maximin criteria). } \details{ Latin hypercube sampling (LHS) was developed to generate a distribution of collections of parameter values from a multidimensional distribution. A square grid containing possible sample points is a Latin square iff there is only one sample in each row and each column. A Latin hypercube is the generalisation of this concept to an arbitrary number of dimensions. When sampling a function of \code{k} variables, the range of each variable is divided into \code{n} equally probable intervals. \code{n} sample points are then drawn such that a Latin Hypercube is created. Latin Hypercube sampling generates more efficient estimates of desired parameters than simple Monte Carlo sampling. This program generates a Latin Hypercube Sample by creating random permutations of the first \code{n} integers in each of \code{k} columns and then transforming those integers into n sections of a standard uniform distribution. Random values are then sampled from within each of the n sections. Once the sample is generated, the uniform sample from a column can be transformed to any distribution by using the quantile functions, e.g. qnorm(). Different columns can have different distributions. Here, values are added to the design one by one such that the maximin criteria is satisfied. } \examples{ set.seed(1234) A1 <- maximinLHS(4, 3, dup=2) A2 <- maximinLHS(4, 3, method="build", dup=2) A3 <- maximinLHS(4, 3, method="iterative", eps=0.05, maxIter=100, optimize.on="grid") A4 <- maximinLHS(4, 3, method="iterative", eps=0.05, maxIter=100, optimize.on="result") } \references{ Stein, M. (1987) Large Sample Properties of Simulations Using Latin Hypercube Sampling. \emph{Technometrics}. \bold{29}, 143--151. This function is motivated by the MATLAB program written by John Burkardt and modified 16 Feb 2005 \url{http://www.csit.fsu.edu/~burkardt/m_src/ihs/ihs.m} } \seealso{ [randomLHS()], [geneticLHS()], [improvedLHS()] and [optimumLHS()] to generate Latin Hypercube Samples. [optAugmentLHS()], [optSeededLHS()], and [augmentLHS()] to modify and augment existing designs. } \keyword{design} lhs/man/oa_to_oalhs.Rd0000644000176200001440000000127413425355422014402 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/oa_to_oalhs.R \name{oa_to_oalhs} \alias{oa_to_oalhs} \title{Create a Latin hypercube from an orthogonal array} \usage{ oa_to_oalhs(n, k, oa) } \arguments{ \item{n}{the number of samples or rows in the LHS (integer)} \item{k}{the number of parameters or columns in the LHS (integer)} \item{oa}{the orthogonal array to be used as the basis for the LHS (matrix of integers) or data.frame of factors} } \value{ a numeric matrix which is a Latin hypercube sample } \description{ Create a Latin hypercube from an orthogonal array } \examples{ oa <- createBose(3, 4, TRUE) B <- oa_to_oalhs(9, 4, oa) } lhs/man/improvedLHS.Rd0000644000176200001440000000556613425060620014310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/improvedLHS.r \name{improvedLHS} \alias{improvedLHS} \title{Improved Latin Hypercube Sample} \usage{ improvedLHS(n, k, dup = 1) } \arguments{ \item{n}{The number of partitions (simulations or design points or rows)} \item{k}{The number of replications (variables or columns)} \item{dup}{A factor that determines the number of candidate points used in the search. A multiple of the number of remaining points than can be added.} } \value{ An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] } \description{ Draws a Latin Hypercube Sample from a set of uniform distributions for use in creating a Latin Hypercube Design. This function attempts to optimize the sample with respect to an optimum euclidean distance between design points. } \details{ Latin hypercube sampling (LHS) was developed to generate a distribution of collections of parameter values from a multidimensional distribution. A square grid containing possible sample points is a Latin square iff there is only one sample in each row and each column. A Latin hypercube is the generalisation of this concept to an arbitrary number of dimensions. When sampling a function of \code{k} variables, the range of each variable is divided into \code{n} equally probable intervals. \code{n} sample points are then drawn such that a Latin Hypercube is created. Latin Hypercube sampling generates more efficient estimates of desired parameters than simple Monte Carlo sampling. This program generates a Latin Hypercube Sample by creating random permutations of the first \code{n} integers in each of \code{k} columns and then transforming those integers into n sections of a standard uniform distribution. Random values are then sampled from within each of the n sections. Once the sample is generated, the uniform sample from a column can be transformed to any distribution byusing the quantile functions, e.g. qnorm(). Different columns can have different distributions. This function attempts to optimize the sample with respect to an optimum euclidean distance between design points. \deqn{Optimum distance = frac{n}{n^{\frac{1.0}{k}}}}{Optimum distance = n/n^(1.0/k)} } \examples{ set.seed(1234) A <- improvedLHS(4, 3, 2) } \references{ Beachkofski, B., Grandhi, R. (2002) Improved Distributed Hypercube Sampling \emph{American Institute of Aeronautics and Astronautics Paper} \bold{1274}. This function is based on the MATLAB program written by John Burkardt and modified 16 Feb 2005 \url{http://www.csit.fsu.edu/~burkardt/m_src/ihs/ihs.m} } \seealso{ [randomLHS()], [geneticLHS()], [maximinLHS()], and [optimumLHS()] to generate Latin Hypercube Samples. [optAugmentLHS()], [optSeededLHS()], and [augmentLHS()] to modify and augment existing designs. } \keyword{design} lhs/man/optSeededLHS.Rd0000644000176200001440000000352313425060620014366 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/optSeededLHS.R \name{optSeededLHS} \alias{optSeededLHS} \title{Optimum Seeded Latin Hypercube Sample} \usage{ optSeededLHS(seed, m = 0, maxSweeps = 2, eps = 0.1, verbose = FALSE) } \arguments{ \item{seed}{The number of partitions (simulations or design points)} \item{m}{The number of additional points to add to the seed matrix \code{seed}. default value is zero. If m is zero then the seed design is optimized.} \item{maxSweeps}{The maximum number of times the CP algorithm is applied to all the columns.} \item{eps}{The optimal stopping criterion} \item{verbose}{Print informational messages} } \value{ An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] } \description{ Augments an existing Latin Hypercube Sample, adding points to the design, while maintaining the \emph{latin} properties of the design. This function then uses the columnwise pairwise (\acronym{CP}) algoritm to optimize the design. The original design is not necessarily maintained. } \details{ Augments an existing Latin Hypercube Sample, adding points to the design, while maintaining the \emph{latin} properties of the design. This function then uses the \acronym{CP} algoritm to optimize the design. The original design is not necessarily maintained. } \examples{ set.seed(1234) a <- randomLHS(4,3) b <- optSeededLHS(a, 2, 2, .1) } \references{ Stein, M. (1987) Large Sample Properties of Simulations Using Latin Hypercube Sampling. \emph{Technometrics}. \bold{29}, 143--151. } \seealso{ [randomLHS()], [geneticLHS()], [improvedLHS()], [maximinLHS()], and [optimumLHS()] to generate Latin Hypercube Samples. [optAugmentLHS()] and [augmentLHS()] to modify and augment existing designs. } \keyword{design} lhs/man/augmentLHS.Rd0000644000176200001440000000473413425060620014117 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/augmentLHS.R \name{augmentLHS} \alias{augmentLHS} \title{Augment a Latin Hypercube Design} \usage{ augmentLHS(lhs, m = 1) } \arguments{ \item{lhs}{The Latin Hypercube Design to which points are to be added. Contains an existing latin hypercube design with a number of rows equal to the points in the design (simulations) and a number of columns equal to the number of variables (parameters). The values of each cell must be between 0 and 1 and uniformly distributed} \item{m}{The number of additional points to add to matrix \code{lhs}} } \value{ An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] } \description{ Augments an existing Latin Hypercube Sample, adding points to the design, while maintaining the \emph{latin} properties of the design. } \details{ Augments an existing Latin Hypercube Sample, adding points to the design, while maintaining the \emph{latin} properties of the design. Augmentation is perfomed in a random manner. The algorithm used by this function has the following steps. First, create a new matrix to hold the candidate points after the design has been re-partitioned into \eqn{(n+m)^{2}}{(n+m)^2} cells, where n is number of points in the original \code{lhs} matrix. Then randomly sweep through each column (1\ldots\code{k}) in the repartitioned design to find the missing cells. For each column (variable), randomly search for an empty row, generate a random value that fits in that row, record the value in the new matrix. The new matrix can contain more filled cells than \code{m} unles \eqn{m = 2n}, in which case the new matrix will contain exactly \code{m} filled cells. Finally, keep only the first m rows of the new matrix. It is guaranteed to have \code{m} full rows in the new matrix. The deleted rows are partially full. The additional candidate points are selected randomly due to the random search for empty cells. } \examples{ set.seed(1234) a <- randomLHS(4,3) b <- augmentLHS(a, 2) } \references{ Stein, M. (1987) Large Sample Properties of Simulations Using Latin Hypercube Sampling. \emph{Technometrics}. \bold{29}, 143--151. } \seealso{ [randomLHS()], [geneticLHS()], [improvedLHS()], [maximinLHS()], and [optimumLHS()] to generate Latin Hypercube Samples. [optAugmentLHS()] and [optSeededLHS()] to modify and augment existing designs. } \author{ Rob Carnell } \keyword{design} lhs/man/geneticLHS.Rd0000644000176200001440000000757513425060620014103 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/geneticLHS.R \name{geneticLHS} \alias{geneticLHS} \title{Latin Hypercube Sampling with a Genetic Algorithm} \usage{ geneticLHS(n = 10, k = 2, pop = 100, gen = 4, pMut = 0.1, criterium = "S", verbose = FALSE) } \arguments{ \item{n}{The number of partitions (simulations or design points or rows)} \item{k}{The number of replications (variables or columns)} \item{pop}{The number of designs in the initial population} \item{gen}{The number of generations over which the algorithm is applied} \item{pMut}{The probability with which a mutation occurs in a column of the progeny} \item{criterium}{The optimality criterium of the algorithm. Default is \code{S}. \code{Maximin} is also supported} \item{verbose}{Print informational messages. Default is \code{FALSE}} } \value{ An \code{n} by \code{k} Latin Hypercube Sample matrix with values uniformly distributed on [0,1] } \description{ Draws a Latin Hypercube Sample from a set of uniform distributions for use in creating a Latin Hypercube Design. This function attempts to optimize the sample with respect to the S optimality criterion through a genetic type algorithm. } \details{ Latin hypercube sampling (LHS) was developed to generate a distribution of collections of parameter values from a multidimensional distribution. A square grid containing possible sample points is a Latin square iff there is only one sample in each row and each column. A Latin hypercube is the generalisation of this concept to an arbitrary number of dimensions. When sampling a function of \code{k} variables, the range of each variable is divided into \code{n} equally probable intervals. \code{n} sample points are then drawn such that a Latin Hypercube is created. Latin Hypercube sampling generates more efficient estimates of desired parameters than simple Monte Carlo sampling. This program generates a Latin Hypercube Sample by creating random permutations of the first \code{n} integers in each of \code{k} columns and then transforming those integers into n sections of a standard uniform distribution. Random values are then sampled from within each of the n sections. Once the sample is generated, the uniform sample from a column can be transformed to any distribution by using the quantile functions, e.g. qnorm(). Different columns can have different distributions. S-optimality seeks to maximize the mean distance from each design point to all the other points in the design, so the points are as spread out as possible. Genetic Algorithm: \enumerate{ \item Generate \code{pop} random latin hypercube designs of size \code{n} by \code{k} \item Calculate the S optimality measure of each design \item Keep the best design in the first position and throw away half of the rest of the population \item Take a random column out of the best matrix and place it in a random column of each of the other matricies, and take a random column out of each of the other matricies and put it in copies of the best matrix thereby causing the progeny \item For each of the progeny, cause a genetic mutation \code{pMut} percent of the time. The mutation is accomplished by swtching two elements in a column } } \examples{ set.seed(1234) A <- geneticLHS(4, 3, 50, 5, .25) } \references{ Stocki, R. (2005) A method to improve design reliability using optimal Latin hypercube sampling \emph{Computer Assisted Mechanics and Engineering Sciences} \bold{12}, 87--105. Stein, M. (1987) Large Sample Properties of Simulations Using Latin Hypercube Sampling. \emph{Technometrics}. \bold{29}, 143--151. } \seealso{ [randomLHS()], [improvedLHS()], [maximinLHS()], and [optimumLHS()] to generate Latin Hypercube Samples. [optAugmentLHS()] [optSeededLHS()], and [augtmentLHS()] to modify and augment existing designs. } \author{ Rob Carnell } \keyword{design} lhs/man/randomLHS.Rd0000644000176200001440000000166413416426305013744 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/randomLHS.r \name{randomLHS} \alias{randomLHS} \title{Construct a random Latin hypercube design} \usage{ randomLHS(n, k, preserveDraw = FALSE) } \arguments{ \item{n}{the number of rows or samples} \item{k}{the number of columns or parameters/variables} \item{preserveDraw}{should the draw be constructed so that it is the same for variable numbers of columns?} } \value{ a Latin hypercube sample } \description{ \code{randomLHS(4,3)} returns a 4x3 matrix with each column constructed as follows: A random permutation of (1,2,3,4) is generated, say (3,1,2,4) for each of K columns. Then a uniform random number is picked from each indicated quartile. In this example a random number between .5 and .75 is chosen, then one between 0 and .25, then one between .25 and .5, finally one between .75 and 1. } \examples{ a <- randomLHS(5, 3) } lhs/man/createBoseBushl.Rd0000644000176200001440000000164413420216024015153 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/createOA.R \name{createBoseBushl} \alias{createBoseBushl} \title{Create an orthogonal array using the Bose-Bush algorithm with alternate strength >= 3} \usage{ createBoseBushl(q, ncol, lambda, bRandom = TRUE) } \arguments{ \item{q}{the number of symbols in the array} \item{ncol}{number of parameters or columns} \item{lambda}{the lambda of the BoseBush algorithm} \item{bRandom}{should the array be randomized} } \value{ an orthogonal array } \description{ Create an orthogonal array using the Bose-Bush algorithm with alternate strength >= 3 } \examples{ A <- createBoseBushl(3, 3, 3, TRUE) B <- createBoseBushl(4, 4, 16, TRUE) } \seealso{ Other methods to create orthogonal arrays [createBoseBush()], [createBose()], [createBush()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBusht()] } lhs/man/create_oalhs.Rd0000644000176200001440000000145213425060620014533 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/create_oalhs.R \name{create_oalhs} \alias{create_oalhs} \title{Create an orthogonal array Latin hypercube} \usage{ create_oalhs(n, k, bChooseLargerDesign, bverbose) } \arguments{ \item{n}{the number of samples or rows in the LHS (integer)} \item{k}{the number of parameters or columns in the LHS (integer)} \item{bChooseLargerDesign}{should a larger oa design be chosen than the n and k requested?} \item{bverbose}{should information be printed with execution} } \value{ a numeric matrix which is an orthogonal array Latin hypercube sample } \description{ Create an orthogonal array Latin hypercube } \examples{ set.seed(34) A <- create_oalhs(9, 4, TRUE, FALSE) B <- create_oalhs(9, 4, TRUE, FALSE) }