lhs/0000755000176200001440000000000014347432332011045 5ustar liggesuserslhs/NAMESPACE0000644000176200001440000000131014216201655012254 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_galois_field) export(create_oalhs) export(geneticLHS) export(get_library_versions) export(improvedLHS) export(maximinLHS) export(oa_to_oalhs) export(optAugmentLHS) export(optSeededLHS) export(optimumLHS) export(poly2int) export(poly_prod) export(poly_sum) export(randomLHS) export(runifint) import(Rcpp) importFrom(stats,dist) importFrom(stats,na.exclude) importFrom(stats,na.omit) importFrom(stats,runif) importFrom(utils,packageVersion) useDynLib(lhs) lhs/ChangeLog0000644000176200001440000000013314220725306012610 0ustar liggesusersFor recent changes, see the git logs at https://github.com/bertcarnell/lhs/commits/master lhs/man/0000755000176200001440000000000014115430532011611 5ustar liggesuserslhs/man/createBoseBush.Rd0000644000176200001440000000311713734234256015013 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{ The \code{bosebush} program produces \code{OA( 2q^2, k, q, 2 )}, \code{k <= 2q+1}, for powers of 2, \code{q=2^r}. } \details{ From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} columns with every element being one of \code{q} symbols \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} submatrix, the \code{q^t} possible distinct rows, all appear the same number of times. This number is the index of the array, commonly denoted \code{lambda}. Clearly, \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. } \examples{ A <- createBoseBush(4, 3, FALSE) B <- createBoseBush(8, 3, TRUE) } \references{ Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 R.C. Bose and K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 508-524. } \seealso{ Other methods to create orthogonal arrays [createBush()], [createBose()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBusht()], [createBoseBushl()] } lhs/man/createBusht.Rd0000644000176200001440000000327013734234256014366 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{ The \code{busht} program produces \code{OA( q^t, k, q, t )}, \code{k <= q+1}, \code{t>=3}, for prime powers \code{q}. } \details{ From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} columns with every element being one of \code{q} symbols \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} submatrix, the \code{q^t} possible distinct rows, all appear the same number of times. This number is the index of the array, commonly denoted \code{lambda}. Clearly, \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. } \examples{ set.seed(1234) A <- createBusht(3, 4, 2, TRUE) B <- createBusht(3, 4, 3, FALSE) G <- createBusht(3, 4, 3, TRUE) } \references{ Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 426-434 } \seealso{ Other methods to create orthogonal arrays [createBoseBush()], [createBose()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBoseBushl()] } lhs/man/createAddelKemp3.Rd0000644000176200001440000000326413734234256015215 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 \code{2q^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{ The \code{addelkemp3} program produces \code{OA( 2*q^3, k, q, 2 )}, \code{k <= 2q^2+2q+1}, for prime powers \code{q}. \code{q} may be an odd prime power, or \code{q} may be 2 or 4. } \details{ From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} columns with every element being one of \code{q} symbols \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} submatrix, the \code{q^t} possible distinct rows, all appear the same number of times. This number is the index of the array, commonly denoted \code{lambda}. Clearly, \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. } \examples{ A <- createAddelKemp3(3, 3, TRUE) B <- createAddelKemp3(3, 5, FALSE) } \references{ Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 S. Addelman and O. Kempthorne (1961) Annals of Mathematical Statistics, Vol 32 pp 1167-1176. } \seealso{ Other methods to create orthogonal arrays [createBushBush()], [createBose()], [createAddelKemp()], [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/createBush.Rd0000644000176200001440000000304013734234256014175 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{ The \code{bush} program produces \code{OA( q^3, k, q, 3 )}, \code{k <= q+1} for prime powers \code{q}. } \details{ From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} columns with every element being one of \code{q} symbols \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} submatrix, the \code{q^t} possible distinct rows, all appear the same number of times. This number is the index of the array, commonly denoted \code{lambda}. Clearly, \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. } \examples{ A <- createBush(3, 3, FALSE) B <- createBush(4, 5, TRUE) } \references{ Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 426-434 } \seealso{ Other methods to create orthogonal arrays [createBoseBush()], [createBose()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBusht()], [createBoseBushl()] } lhs/man/lhs-package.Rd0000644000176200001440000000114113637001570014260 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 and Orthogonal Array 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/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/createBose.Rd0000644000176200001440000000300413734234256014164 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{ The \code{bose} program produces \code{OA( q^2, k, q, 2 )}, \code{k <= q+1} for prime powers \code{q}. } \details{ From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} columns with every element being one of \code{q} symbols \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} submatrix, the \code{q^t} possible distinct rows, all appear the same number of times. This number is the index of the array, commonly denoted \code{lambda}. Clearly, \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. } \examples{ A <- createBose(3, 3, FALSE) B <- createBose(5, 4, TRUE) } \references{ Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 R.C. Bose (1938) Sankhya Vol 3 pp 323-338 } \seealso{ Other methods to create orthogonal arrays [createBush()], [createBoseBush()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBusht()], [createBoseBushl()] } lhs/man/createAddelKempN.Rd0000644000176200001440000000301313734234256015240 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 with \code{2q^n} rows.} \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{ The \code{addelkempn} program produces \code{OA( 2*q^n, k, q, 2 )}, \code{k <= 2(q^n - 1)/(q-1)-1}, for prime powers \code{q}. \code{q} may be an odd prime power, or \code{q} may be 2 or 4. } \details{ From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} columns with every element being one of \code{q} symbols \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} submatrix, the \code{q^t} possible distinct rows, all appear the same number of times. This number is the index of the array, commonly denoted \code{lambda}. Clearly, \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. } \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/improvedLHS.Rd0000644000176200001440000000557314115501162014304 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{https://people.math.sc.edu/Burkardt/m_src/ihs/ihs.html} } \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/optimumLHS.Rd0000644000176200001440000000577613636661005014170 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/createAddelKemp.Rd0000644000176200001440000000312613734234256015127 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{ The \code{addelkemp} program produces \code{OA( 2q^2, k, q, 2 )}, \code{k <= 2q+1}, for odd prime powers \code{q}. } \details{ From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} columns with every element being one of \code{q} symbols \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} submatrix, the \code{q^t} possible distinct rows, all appear the same number of times. This number is the index of the array, commonly denoted \code{lambda}. Clearly, \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. } \examples{ A <- createAddelKemp(3, 3, TRUE) B <- createAddelKemp(3, 5, FALSE) } \references{ Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 S. Addelman and O. Kempthorne (1961) Annals of Mathematical Statistics, Vol 32 pp 1167-1176. } \seealso{ Other methods to create orthogonal arrays [createBoseBush()], [createBose()], [createAddelKemp3()], [createAddelKempN()], [createBusht()], [createBoseBushl()] } 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) } lhs/man/geneticLHS.Rd0000644000176200001440000000762213636661005014104 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/poly2int.Rd0000644000176200001440000000075614115430532013670 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/galois_field.R \name{poly2int} \alias{poly2int} \title{Convert polynomial to integer in 0..q-1} \usage{ poly2int(p, n, poly) } \arguments{ \item{p}{modulus} \item{n}{the length of poly} \item{poly}{the polynomial vector} } \value{ an integer } \description{ Convert polynomial to integer in 0..q-1 } \examples{ gf <- create_galois_field(4) stopifnot(poly2int(gf$p, gf$n, c(0, 0)) == 0) } lhs/man/create_galois_field.Rd0000644000176200001440000000343314115430532016047 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/galois_field.R \name{create_galois_field} \alias{create_galois_field} \title{Create a Galois field} \usage{ create_galois_field(q) } \arguments{ \item{q}{The order of the Galois Field q = p^n} } \value{ a GaloisField object containing \describe{ \item{n}{q = p^n} \item{p}{The prime modulus of the field q=p^n} \item{q}{The order of the Galois Field q = p^n. \code{q} must be a prime power.} \item{xton}{coefficients of the characteristic polynomial where the first coefficient is on $x^0$, the second is on $x^1$ and so on} \item{inv}{An index for which row of \code{poly} (zero based) is the multiplicative inverse of this row. An \code{NA} indicates that this row of \code{poly} has no inverse. e.g. c(3, 4) means that row 4=3+1 is the inverse of row 1 and row 5=4+1 is the inverse of row 2} \item{neg}{An index for which row of \code{poly} (zero based) is the negative or additive inverse of this row. An \code{NA} indicates that this row of \code{poly} has no negative. e.g. c(3, 4) means that row 4=3+1 is the negative of row 1 and row 5=4+1 is the negative of row 2} \item{root}{An index for which row of \code{poly} (zero based) is the square root of this row. An \code{NA} indicates that this row of \code{poly} has no square root. e.g. c(3, 4) means that row 4=3+1 is the square root of row 1 and row 5=4+1 is the square root of row 2} \item{plus}{sum table of the Galois Field} \item{times}{multiplication table of the Galois Field} \item{poly}{rows are polynomials of the Galois Field where the entries are the coefficients of the polynomial where the first coefficient is on $x^0$, the second is on $x^1$ and so on} } } \description{ Create a Galois field } \examples{ gf <- create_galois_field(4); } lhs/man/optSeededLHS.Rd0000644000176200001440000000352013636661005014373 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/runifint.Rd0000644000176200001440000000075113636661005013751 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/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/createBoseBushl.Rd0000644000176200001440000000342713734234256015173 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{ The \code{bosebushl} program produces \code{OA( lambda*q^2, k, q, 2 )}, \code{k <= lambda*q+1}, for prime powers \code{q} and \code{lambda > 1}. Both \code{q} and \code{lambda} must be powers of the same prime. } \details{ From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} columns with every element being one of \code{q} symbols \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} submatrix, the \code{q^t} possible distinct rows, all appear the same number of times. This number is the index of the array, commonly denoted \code{lambda}. Clearly, \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. } \examples{ A <- createBoseBushl(3, 3, 3, TRUE) B <- createBoseBushl(4, 4, 16, TRUE) } \references{ Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 R.C. Bose and K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 508-524. } \seealso{ Other methods to create orthogonal arrays [createBoseBush()], [createBose()], [createBush()], [createAddelKemp()], [createAddelKemp3()], [createAddelKempN()], [createBusht()] } lhs/man/poly_prod.Rd0000644000176200001440000000121114115430532014102 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/galois_field.R \name{poly_prod} \alias{poly_prod} \title{Multiplication in polynomial representation} \usage{ poly_prod(p, n, xton, p1, p2) } \arguments{ \item{p}{modulus} \item{n}{length of polynomials} \item{xton}{characteristic polynomial vector for the field (x to the n power)} \item{p1}{polynomial vector 1} \item{p2}{polynomial vector 2} } \value{ the product of p1 and p2 } \description{ Multiplication in polynomial representation } \examples{ gf <- create_galois_field(4) a <- poly_prod(gf$p, gf$n, gf$xton, c(1, 0), c(0, 1)) stopifnot(all(a == c(0, 1))) } lhs/man/maximinLHS.Rd0000644000176200001440000000751114115501162014113 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{https://people.math.sc.edu/Burkardt/m_src/ihs/ihs.html} } \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/poly_sum.Rd0000644000176200001440000000103514115430532013746 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/galois_field.R \name{poly_sum} \alias{poly_sum} \title{Addition in polynomial representation} \usage{ poly_sum(p, n, p1, p2) } \arguments{ \item{p}{modulus} \item{n}{length of polynomial 1 and 2} \item{p1}{polynomial vector 1} \item{p2}{polynomial vector 2} } \value{ the sum of p1 and p2 } \description{ Addition in polynomial representation } \examples{ gf <- create_galois_field(4) a <- poly_sum(gf$p, gf$n, c(1, 0), c(0, 1)) stopifnot(all(a == c(1, 1))) } lhs/man/get_library_versions.Rd0000644000176200001440000000065213754762666016366 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_library_versions.R \name{get_library_versions} \alias{get_library_versions} \title{Get version information for all libraries in the lhs package} \usage{ get_library_versions() } \value{ a character string containing the versions } \description{ Get version information for all libraries in the lhs package } \examples{ get_library_versions() } 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/DESCRIPTION0000644000176200001440000000147214347432332012557 0ustar liggesusersPackage: lhs Title: Latin Hypercube Samples Version: 1.1.6 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 and Orthogonal Array Latin Hypercube Samples. License: GPL-3 Encoding: UTF-8 Depends: R (>= 3.4.0) LinkingTo: Rcpp Imports: Rcpp Suggests: testthat, assertthat, DoE.base, knitr, rmarkdown URL: https://github.com/bertcarnell/lhs BugReports: https://github.com/bertcarnell/lhs/issues RoxygenNote: 7.2.2 VignetteBuilder: knitr NeedsCompilation: yes Packaged: 2022-12-17 19:41:08 UTC; bertc Author: Rob Carnell [aut, cre] Maintainer: Rob Carnell Repository: CRAN Date/Publication: 2022-12-17 21:30:02 UTC lhs/build/0000755000176200001440000000000014347415522012146 5ustar liggesuserslhs/build/vignette.rds0000644000176200001440000000052414347415522014506 0ustar liggesusersRMO@jmIVS=uLa KS{Wn{F.-J>}0 &WQ9piQQM˹OӈC*dH R5׊^_TW" "!EԃvhË^ӆ\$Rڜ 82k[״76WinxYppb{Sy5ץE Kg=17Kk^T꽊R3`S.=SIFYh%[=Q(bȍP 90GHOѰlhs/tests/0000755000176200001440000000000013415250176012206 5ustar liggesuserslhs/tests/testthat/0000755000176200001440000000000014347432332014047 5ustar liggesuserslhs/tests/testthat/test-galois_field.R0000644000176200001440000001102014115430532017553 0ustar liggesuserstest_that("Galois Fields Work", { test_field <- function(q, p, n) { gf <- create_galois_field(q) expect_equal(gf$p, p) expect_equal(gf$q, q) expect_equal(gf$n, n) } test_field(2, 2, 1) test_field(3, 3, 1) test_field(4, 2, 2) test_field(9, 3, 2) # q cannot be less than 2 expect_error(create_galois_field(-1)) expect_error(create_galois_field(1)) # q must be a prime power expect_error(create_galois_field(100000000)) expect_error(create_galois_field(35)) # the prime power can't be too large expect_error(create_galois_field(2^30)) }) test_that("Associative", { check_associative <- function(gf){ for (i in 1:gf$q) { for (j in 1:gf$q) { for (k in 1:gf$q) { sum1 <- poly_sum(gf$p, gf$n, gf$poly[i,], gf$poly[j,]) sum2 <- poly_sum(gf$p, gf$n, sum1, gf$poly[k,]) sum3 <- poly_sum(gf$p, gf$n, gf$poly[j,], gf$poly[k,]) sum4 <- poly_sum(gf$p, gf$n, gf$poly[i,], sum3) expect_equal(sum2, sum4) prod1 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[i,], gf$poly[j,]) prod2 <- poly_prod(gf$p, gf$n, gf$xton, prod1, gf$poly[k,]) prod3 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[j,], gf$poly[k,]) prod4 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[i,], prod3) expect_equal(prod2, prod4) } } } } check_associative(create_galois_field(3)) check_associative(create_galois_field(4)) check_associative(create_galois_field(9)) check_associative(create_galois_field(8)) }) test_that("Commutative", { check_commutative <- function(gf) { for (i in 1:gf$q) { for (j in 1:gf$q) { sum1 <- poly_sum(gf$p, gf$n, gf$poly[i,], gf$poly[j,]) sum2 <- poly_sum(gf$p, gf$n, gf$poly[j,], gf$poly[i,]) expect_equal(sum1, sum2) prod1 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[i,], gf$poly[j,]) prod2 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[j,], gf$poly[i,]) expect_equal(prod1, prod2) } } } check_commutative(create_galois_field(3)) check_commutative(create_galois_field(4)) check_commutative(create_galois_field(9)) check_commutative(create_galois_field(8)) }) test_that("Identity", { check_identity <- function(gf, zero, one) { for (i in 1:gf$q) { sum1 <- poly_sum(gf$p, gf$n, gf$poly[i,], zero) expect_equal(sum1, gf$poly[i,]) prod1 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[i,], one) expect_equal(prod1, gf$poly[i,]) } } check_identity(create_galois_field(3), 0, 1) check_identity(create_galois_field(4), c(0,0), c(1,0)) check_identity(create_galois_field(9), c(0,0), c(1,0)) check_identity(create_galois_field(8), c(0,0,0), c(1,0,0)) }) test_that("Inverse", { check_inverse <- function(gf, zero, one) { #gf <- create_galois_field(3) for (i in 1:gf$q) { #i <- 1 sum1 <- poly_sum(gf$p, gf$n, gf$poly[i,], gf$poly[gf$neg[i] + 1,]) expect_equal(sum1, zero) if (!is.na(gf$inv[i])) { prod1 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[i,], gf$poly[gf$inv[i] + 1,]) expect_equal(prod1, one) } } } check_inverse(create_galois_field(3), 0, 1) check_inverse(create_galois_field(4), c(0,0), c(1,0)) check_inverse(create_galois_field(9), c(0,0), c(1,0)) check_inverse(create_galois_field(8), c(0,0,0), c(1,0,0)) }) test_that("Distributive", { check_distributive <- function(gf) { for (i in 1:gf$q) { for (j in 1:gf$q) { for (k in 1:gf$q) { sum1 <- poly_sum(gf$p, gf$n, gf$poly[j,], gf$poly[k,]) prod1 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[i,], sum1) prod2 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[i,], gf$poly[j,]) prod3 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[i,], gf$poly[k,]) sum2 <- poly_sum(gf$p, gf$n, prod2, prod3) expect_equal(prod1, sum2) } } } } check_distributive(create_galois_field(3)) check_distributive(create_galois_field(4)) check_distributive(create_galois_field(9)) check_distributive(create_galois_field(8)) }) test_that("Roots", { check_roots <- function(gf) { #gf <- create_galois_field(3) for (i in 1:gf$q) { if (!is.na(gf$root[i])){ prod1 <- poly_prod(gf$p, gf$n, gf$xton, gf$poly[gf$root[i] + 1,], gf$poly[gf$root[i] + 1,]) expect_equal(gf$poly[i, ], prod1) } } } check_roots(create_galois_field(3)) check_roots(create_galois_field(4)) check_roots(create_galois_field(9)) check_roots(create_galois_field(8)) }) 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-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-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-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-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/tests/testthat/helper-lhs.R0000644000176200001440000000206013753062737016243 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) } encodeOA <- function(X, n) { assertthat::assert_that(n > 1 & is.integer(n), msg = "n must be an integer > 1") if (n == 2) { # 0, 1 => -1, 1 X <- X*2 - 1 } else if (n == 3) { # 0, 1, 2 => -1, 0, 1 X <- X - 1 } else if (n == 4) { # 0, 1, 2, 3 => -1, -1/3, 1/3, 1 X <- X * 2 / 3 - 1 } else if (n > 4) { X <- X * 2 / (n - 1) - 1 } return(X) } lhs/tests/testthat/test-randomlhs.r0000644000176200001440000000505713734227456017215 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)) }) # in version 1.0.1 and prior, this did not necessarily cause a segfault # in all attempts. It was a relatively random occurence test_that("Segfault does not occur with gctorture", { for (i in 1:20) { gctorture(TRUE) A <- randomLHS(10, 4) gctorture(FALSE) } expect_true(checkLatinHypercube(A)) }) lhs/tests/testthat/test-createoa.R0000644000176200001440000001226713753062737016752 0ustar liggesusers# Copyright 2019 Robert Carnell context("test-createoa") test_that("createBose works", { B <- createBose(2, 3, FALSE) expect_true(checkOA(encodeOA(B, 2L))) B <- createBose(3, 4, FALSE) expect_true(checkOA(encodeOA(B, 3L))) 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) expect_true(checkOA(encodeOA(B, 2L))) B <- createBoseBush(4, 8, FALSE) expect_true(checkOA(encodeOA(B, 4L))) 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) expect_warning({ B <- createBoseBush(8, 17) }) expect_equal(nrow(B), 2*8^2) expect_equal(ncol(B), 17) expect_true(checkOA(encodeOA(B, 8L))) expect_error({ B <- createBoseBush(8, 18) }) }) test_that("createBush works", { B <- createBush(3, 3, FALSE) expect_true(checkOA(encodeOA(B, 3L))) B <- createBush(4, 5, FALSE) expect_true(checkOA(encodeOA(B, 4L))) B <- createBush(3, 3) expect_equal(nrow(B), 3^3) expect_equal(ncol(B), 3) expect_true(checkOA(encodeOA(B, 3L))) B <- createBush(3, 4) expect_equal(nrow(B), 3^3) expect_equal(ncol(B), 4) expect_true(checkOA(encodeOA(B, 3L))) B <- createBush(5, 4) expect_equal(nrow(B), 5^3) expect_equal(ncol(B), 4) expect_true(checkOA(encodeOA(B, 5L))) expect_warning({ B <- createBush(2, 3) }) expect_equal(nrow(B), 2^3) expect_equal(ncol(B), 3) expect_true(checkOA(encodeOA(B, 2L))) expect_error({ B <- createBush(2, 4) }) }) test_that("createAddelKemp works", { B <- createAddelKemp(2, 4, FALSE) expect_true(checkOA(encodeOA(B, 2L))) B <- createAddelKemp(3, 6, FALSE) expect_true(checkOA(encodeOA(B, 3L))) 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) expect_warning({ B <- createAddelKemp(q = 3^1, ncol = 2*3 + 1, bRandom = FALSE) }, regexp = "Warning:") expect_true(checkOA(encodeOA(B, 3L))) expect_equal(7, ncol(B)) expect_equal(18, nrow(B)) }) test_that("createAddelKemp3 works", { B <- createAddelKemp3(2, 13, FALSE) expect_true(checkOA(encodeOA(B, 2L))) B <- createAddelKemp3(3, 25, FALSE) expect_true(checkOA(encodeOA(B, 3L))) 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) expect_true(checkOA(encodeOA(B, 3L))) B <- createBusht(3, 4, 3, FALSE) expect_true(checkOA(encodeOA(B, 3L))) 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) expect_true(checkOA(encodeOA(B, 3L))) B <- createBoseBushl(4, 4, 16, FALSE) expect_true(checkOA(encodeOA(B, 4L))) B <- createBoseBushl(q = 2^2, ncol = 2*2^2, lambda = 2, bRandom = FALSE) expect_true(checkOA(encodeOA(B, 4L))) expect_warning({ B <- createBoseBushl(q = 2^2, ncol = 2*2^2 + 1, lambda = 2, bRandom = FALSE) }, regexp = "Warning:") expect_true(checkOA(encodeOA(B, 4L))) expect_equal(9, ncol(B)) expect_equal(32, nrow(B)) expect_warning({ B <- createBoseBushl(q = 3^1, ncol = 3*3 + 1, lambda = 3, bRandom = FALSE) }, regexp = "Warning:") expect_true(checkOA(encodeOA(B, 3L))) expect_equal(10, ncol(B)) expect_equal(27, nrow(B)) }) test_that("createAddelKempN works", { B <- createAddelKempN(2, 3, 3, FALSE) expect_true(checkOA(encodeOA(B, 2L))) B <- createAddelKempN(3, 4, 4, FALSE) expect_true(checkOA(encodeOA(B, 3L))) # These two tests were failing prior to lhs 1.1 B <- createAddelKempN(3, 5, 3, FALSE) expect_true(checkOA(encodeOA(B, 3L))) B <- createAddelKempN(3, 25, 3, FALSE) expect_true(checkOA(encodeOA(B, 3L))) }) lhs/tests/testthat/test-get_library_versions.R0000644000176200001440000000023613754762666021424 0ustar liggesuserstest_that("get_library_versions", { a <- get_library_versions() expect_true(is.character(a)) expect_equal(1, length(a)) expect_true(nchar(a) > 10) }) 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-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-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.R0000644000176200001440000000006613415250176014173 0ustar liggesuserslibrary(testthat) library(lhs) test_check("lhs") lhs/src/0000755000176200001440000000000014347415524011640 5ustar liggesuserslhs/src/ak.h0000644000176200001440000000723714215223423012402 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 "GaloisField.h" #include "primes.h" #include "matrix.h" namespace oacpp { /** * Addelkemp class */ namespace oaaddelkemp { /** * Check that the parameters of the addelkemp3 algorithm are consistent * (ncol <= 2q^2+2q+1 * * @param q the order of the Galois field or the number of symbols * @param p the prime basis of the Galois field * @param ncol the number of columns * @return an indicator of success */ int addelkemp3check(int q, int p, int ncol); /** * Addelkemp algorithm for even p * * @param gf a Galois field * @param kay the number of columns * @param b original Addelkemp variable * @param c original Addelkemp variable * @param k original Addelkemp variable * @return an indicator of success */ int akeven(GaloisField & gf, int* kay, std::vector & b, std::vector & c, std::vector & k); /** * Addelkemp algorithm for odd p * * @param gf a Galois field object * @param kay the number of columns * @param b original Addelkemp variable * @param c original Addelkemp variable * @param k original Addelkemp variable * @return an indicator of success */ int akodd(GaloisField & gf, int* kay, std::vector & b, std::vector & c, std::vector & k); /** * Check that the parameters are consistent for the addelkempn algorithm * * @param q the order of Galois field or the number of symbols * @param p the prime basis of the Galois field * @param akn the akn algorithm produces OA(2q^n,ncol,q,2) * @param ncol the number of columns * @return an indicator of success * @throws runtime_exception */ void addelkempncheck(int q, int p, int akn, int ncol); /** * The addelkemp algorithm for general n to produce OA(2q^n,ncol,q,2) * * @param gf a Galois Field * @param akn the akn algorithm produces OA(2q^n,ncol,q,2) * @param A the orthogonal array * @param ncol the number of columns * @return an indicator of success */ int addelkempn(GaloisField & 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(GaloisField & gf, bclib::matrix & A, int ncol ); } } #endif lhs/src/lhs_r.h0000644000176200001440000001107313753062737013126 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" #include "bclibVersion.h" #include "oalibVersion.h" #include "lhslibVersion.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); /** * Get the versions of the bclib, oa, and lhslib C++ libraries * @return String of version information */ RcppExport SEXP get_library_versions(); #endif /* LHS_R_H */ lhs/src/utilityLHS.h0000644000176200001440000003075714215223423014064 0ustar liggesusers/** * @file utilityLHS.h * @author Robert Carnell * @copyright Copyright (c) 2022, 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. * @tparam T the type of values for the Arg1, Arg2, and return */ template struct squareDifference { /** * 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 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 { /** * A 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/matrix.h0000644000176200001440000006406614215223422013315 0ustar liggesusers/** * @file matrix.h * @author Robert Carnell * @copyright Copyright (c) 2022, 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 { 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: // required elements of an iterator class (inherited from std::iterator before it was deprecated) using iterator_category = std::forward_iterator_tag; using value_type = T; using difference_type = T; using pointer = T*; using reference = T&; /** * 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 { 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: // required elements of an iterator class (inherited from std::iterator before it was deprecated) using iterator_category = std::forward_iterator_tag; using value_type = T; using difference_type = T; using pointer = T*; using reference = T&; /** * 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/geneticLHS.cpp0000644000176200001440000002267514215223422014331 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, const 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/optimumLHS.cpp0000644000176200001440000002541714215223423014403 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/utilityLHS.cpp0000644000176200001440000000615414215223423014411 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/bclibVersion.h0000644000176200001440000000176714215223422014431 0ustar liggesusers/** * @file Version.h * @author Robert Carnell * @copyright Copyright (c) 2020, 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 BCLIBVERSION_H #define BCLIBVERSION_H namespace bclib { inline static const char * getVersion() {return "1.0.2";} } #endif lhs/src/oa.cpp0000644000176200001440000005350614215223423012741 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, const 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); } } int OA_str0(int q, const 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, const 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 FAILURE_CHECK; } 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 += static_cast(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 FAILURE_CHECK; } } 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, const 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 FAILURE_CHECK; } if ((static_cast(nrow) % (q * q)) != 0) { 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 FAILURE_CHECK; } 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 += static_cast((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 FAILURE_CHECK; } } } } 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 SUCCESS_CHECK; } int OA_str3(int q, const 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 FAILURE_CHECK; } if (static_cast(nrow) % (q * q * q) != 0) { 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 FAILURE_CHECK; } 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 += static_cast((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 FAILURE_CHECK; } } } } } } 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 SUCCESS_CHECK; } int OA_str4(int q, const 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 FAILURE_CHECK; } if (static_cast(nrow) % (q * q * q * q) != 0) { 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 FAILURE_CHECK; } 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 += static_cast((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 FAILURE_CHECK; } } } } } } } } 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 SUCCESS_CHECK; } int OA_strt(int q, const 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 FAILURE_CHECK; } 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 FAILURE_CHECK; } if (t == 0) { return OA_str0(q, A, verbose); } if (nrow % primes::ipow(q, t) != 0) { 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 FAILURE_CHECK; } 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 != 0; i++) { match *= static_cast(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++) { std::string temp = (i == t - 1) ? ")" : ","; // warning about decaying a pointer when used on next line PRINT_OUTPUT << "A(," << clist[i] << ")" << temp.c_str(); } 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 FAILURE_CHECK; } for (int i = t - 1; i >= 0; i--) // has to be int { qlist[i] = (qlist[i] + 1) % q; if (qlist[i] != 0) { 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] != 0) { 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/optSeededLHS.cpp0000644000176200001440000002402614215223423014620 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/COrthogonalArray.h0000644000176200001440000006274414215223423015231 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 "GaloisField.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 * * This method is not included by default in Art Owens's * project, but it is in the code. It is not compiled in * the makefile. Adding it as a target to the makefile creates a successful 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(); /** * Get available warning message * @return the message */ const std::string getMessage(); /** * Get the method return code * @return the return code */ int getReturnCode(); private: GaloisField 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; /**< a pseudo random number generator */ int m_return_code; std::string m_warning_msg; /** * 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; } inline int COrthogonalArray::getReturnCode() { return m_return_code; } inline const std::string COrthogonalArray::getMessage() { return m_warning_msg; } } #endif lhs/src/construct.h0000644000176200001440000001420514215223423014024 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 "GaloisField.h" #include "ak.h" 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 a Galois field * @param A an matrix to return the orthogonal array * @param ncol the number of columns * @return an indicator of success */ int bose(GaloisField & gf, bclib::matrix & A, int ncol ); /** * Construct an orthogonal array using the bush algorithm * @param gf a Galois field * @param A an matrix to return the orthogonal array * @param str the array strength * @param ncol the desired number of columns * @return an indicator of success */ int bush(GaloisField & gf, bclib::matrix & A, int str, int ncol ); /** * Implement Addelman and Kempthorne's 1961 A.M.S. method with n=2 * * @param gf a Galois field * @param A an matrix to return the orthogonal array * @param ncol the desired number of columns * @return an indicator of success */ int addelkemp(GaloisField & 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 a Galois field * @param B an matrix to return the orthogonal array * @param ncol the desired number of columns * @return an indicator of success */ int bosebush(GaloisField & gf, bclib::matrix & B, int ncol ); /** * Construct an orthogonal array using the bose-bush algorithm * * @param gf a Galois field * @param lam lambda * @param B an matrix to return the orthogonal array * @param ncol the desired number of columns * @return an indicator of success */ int bosebushl(GaloisField & gf, int lam, bclib::matrix & B, int ncol ); /** * Check the input to the bose algorithm * (ncol <= q + 1) where q = p^n * @param q the number of symbols * @param ncol the number of columns * @return an indicator of success */ int bosecheck(int q, int ncol ); /** * Integer to polynomial * @param n the input integer * @param q the order of the Galois field * @param d the degree of the polynomial. A degree 3 polynomial will have 4 coefficients (x^0, x^1, x^2, x^3) * @param coef vector of polynomial coefficients * @return an indicator of success */ 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 the polynomial degree. A degree 3 polynomial will have 4 coefficients (x^0, x^1, x^2, x^3) * @param poly the polynomial coefficients * @param arg the value of the polynomial independent variable * @param value the result * @return an indicator of success */ int polyeval(GaloisField & gf, int d, std::vector & poly, int arg, int* value ); /** * Test the inputs to the Bush algorithm * (ncol <= q + 1, str <= ncol, str < q + 1) * @param q the order of the Galois Field * @param str the orthogonal array strength * @param ncol the number of columns in the orthogonal array * @return an indicator of success */ int bushcheck(int q, int str, int ncol); /** * Test the inputs to the Bose-Bush algorithm * (p == 2, ncol <= 2q + 1) * @param q the order of the Galois Field * @param p the prime basis of the Galois Field (q = p^n) * @param ncol the number of columns in the orthogonal array * @return an indicator of success */ int bosebushcheck(int q, int p, int ncol); /** * Test the inputs to the Bose-Bush algorithm with lambda parameter * (ncol <= lambda*q + 1) * @param s s = q / lambda * @param p the prime basis of the Galois Field * @param lam the lambda parameter * @param ncol the number of columns in the orthogonal array * @return an indicator of success */ int bosebushlcheck(int s, int p, int lam, int ncol); /** * Test the inputs to the Addel-Kemp algorithm * @param q the order of Galois field * @param p the prime basis of the Galois field * @param ncol the number of columns in the orthogonal array * @return an indicator of success */ int addelkempcheck(int q, int p, int ncol); } }// end namespace #endif lhs/src/akn.cpp0000644000176200001440000003325014215223423013105 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 { void addelkempncheck(int q, int p, int akn, int ncol) { 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"; ostringstream_runtime_error(msg); } 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"; ostringstream_runtime_error(msg); } 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"; ostringstream_runtime_error(msg); } } /* Implement Addelman and Kempthorne's 1961 A.M.S. method with n=3 */ int addelkempn(GaloisField & gf, int akn, bclib::matrix & A, int ncol) { int kay; /* A&K notation */ int col, square, ksquare; int monic, elt; size_t numin; size_t aknu = static_cast(akn); addelkempncheck(gf.q, gf.p, akn, ncol); std::vector b(gf.u_q); std::vector c(gf.u_q); std::vector k(gf.u_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(gf.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] != 0) { if (monic == -1) { monic = static_cast(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(gf.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) % gf.q; if (coef[ui] != 0) { break; } coef[ui] = 1; } } for (size_t i = 0; i < aknu; i++) { s[i] = (s[i] + 1) % 2; if (s[i] != 0) { 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] != 0) { if (monic == -1) { monic = static_cast(i); } else { indx[numin++] = static_cast(i); } } } coef[0] = 0; for (size_t i = 1; i < numin + 1; i++) { coef[i] = 1; } int polymax = gf.q * primes::ipow(gf.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) % gf.q; if (coef[ui] != 0) { break; } if (i > 0) { coef[ui] = 1; } } } for (size_t i = 1; i < aknu; i++) { s[i] = (s[i] + 1) % 2; if (s[i] != 0) { 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) % gf.q; if (x[ui] != 0) { break; } } } if (gf.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(gf.q, akn); for (size_t row = static_cast(primes::ipow(gf.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] != 0) { if (monic == -1) { monic = static_cast(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(gf.q - 1, static_cast(numin))) && col < ncol; poly++) { elt = x[monic]; if (numin != 0 && s[0] != 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) % gf.q; if (coef[ui] != 0) { break; } coef[ui] = 1; } } for (size_t i = 0; i < aknu; i++) { s[i] = (s[i] + 1) % 2; if (s[i] != 0) { 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] != 0) { if (monic == -1) { monic = static_cast(i); } else { indx[numin++] = static_cast(i); } } } coef[0] = 0; for (size_t i = 1; i < numin + 1; i++) { coef[i] = 1; } int polymax = gf.q * primes::ipow(gf.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) % gf.q; if (coef[ui] != 0) { break; } coef[ui] = i > 0 ? 1 : 0; } } for (size_t i = 1; i < aknu; i++) { s[i] = (s[i] + 1) % 2; if (s[i] != 0) { 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) % gf.q; if (x[ui] != 0) { break; } } } return SUCCESS_CHECK; } } // end namespace } // end namespace lhs/src/oaLHSUtility.h0000644000176200001440000000370214215223424014333 0ustar liggesusers/** * @file oaLHSUtility.h * @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 . * */ #ifndef OALHSUTILITY_H #define OALHSUTILITY_H #include namespace oalhslib { /** * The the unique column elements of a matrix * * @param A input matrix * @param U output vector of vectors of unique elements by column * @tparam T the type of elements in the input matrix A */ 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/primes.h0000644000176200001440000000430414215223423013276 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 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/init.c0000644000176200001440000000412614347354766012764 0ustar liggesusers#include #include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .Call calls */ extern SEXP create_galois_field(SEXP); extern SEXP create_oalhs(SEXP, SEXP, SEXP, SEXP); extern SEXP geneticLHS_cpp(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP get_library_versions(void); 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 poly_prod(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP poly_sum(SEXP, SEXP, SEXP, SEXP); extern SEXP poly2int(SEXP, SEXP, SEXP); extern SEXP randomLHS_cpp(SEXP, SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"create_galois_field", (DL_FUNC) &create_galois_field, 1}, {"create_oalhs", (DL_FUNC) &create_oalhs, 4}, {"geneticLHS_cpp", (DL_FUNC) &geneticLHS_cpp, 7}, {"get_library_versions", (DL_FUNC) &get_library_versions, 0}, {"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}, {"poly_prod", (DL_FUNC) &poly_prod, 5}, {"poly_sum", (DL_FUNC) &poly_sum, 4}, {"poly2int", (DL_FUNC) &poly2int, 3}, {"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/GaloisField.h0000644000176200001440000000654514215223423014172 0ustar liggesusers/** * @file GaloisField.h * @author Robert Carnell * @copyright Copyright (c) 2020, Robert Carnell * * This class is based on the code by Art Owen in galdef.h, galois.h, xtnset.h, xtndispatch.h, xtndeclare.h * * Reference: * * */ #ifndef GALOISFIELD_H #define GALOISFIELD_H #include "OACommonDefines.h" #include "matrix.h" #include "primes.h" #include namespace oacpp { /** * Class to define a Galois Field and Methods for operations */ class GaloisField { private: void fillAllPolynomials(); void computeSumsAndProducts(); void computeMultiplicativeInverse(); void computeNegative(); void computeRoots(); static std::vector initializePowerCycle(int q); public: /** prime modulus exponent q = p^n*/ int n; /** polynomial vector length */ size_t u_n; /** prime modulus q=p^n*/ int p; /** the order of the field q = p^n */ int q; /** field element vector lenth */ size_t u_q; /** characteristic polynomial of length u_n */ std::vector xton; /** Indicator of which row of poly is the multiplicative inverse of this row of length u_q */ std::vector inv; /** row number of which row of poly is the negative (additive inverse) of this row of length u_q */ std::vector neg; /** root */ std::vector root; /** sum field of dimension u_q x u_q*/ bclib::matrix plus; /** product field of dimension u_q x u_q*/ bclib::matrix times; /** polynomial field of dimension u_q x u_n */ bclib::matrix poly; /** * Construct the Galois Field with order q */ explicit GaloisField(int q); /** * Default Constructor */ GaloisField(); /** * Multiplication in polynomial representation * * @param p modulus * @param u_n length of p1 and p2 * @param xton characteristic polynomial * @param p1 polynomial 1 * @param p2 polynomial 2 * @param prod the product of the polynomials */ static void polyProd(int p, size_t u_n, const std::vector & xton, const std::vector & p1, const std::vector & p2, std::vector & prod); /** * Addition in polynomial representation * * @param p modulus * @param u_n the length of p1 and p2 * @param p1 polynomial 1 * @param p2 polynomial 2 * @param sum the sum of the polynomials */ static void polySum(int p, size_t u_n, const std::vector & p1, const 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 */ static int poly2int(int p, int n, const std::vector & poly); /** * Print a Galois field */ void print(); }; } // end namespace #endif lhs/src/oaLHS.h0000644000176200001440000000672314215223424012755 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/maximinLHS.cpp0000644000176200001440000002033414215223422014343 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/lhs_r_utilities.cpp0000644000176200001440000001462513425376731015560 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/src/improvedLHS.cpp0000644000176200001440000002147514215223422014535 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.h0000644000176200001440000001421414215223422015074 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 /** RNG Macro (See lhs_r.cpp)*/ #define START_RNG Rcpp::RNGScope * tempRNG = new Rcpp::RNGScope(); // instantiate a pointer so that the destructor is not implicitly called /** End RNG Macro (See lhs_r.cpp)*/ #define END_RNG delete tempRNG; // explicitly release the RNG state to avoid memory corruption /** * @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 oldHypercube the seeded lhs * @param optimalityRecordLength 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 & oldHypercube, int optimalityRecordLength, 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, const std::string & criterium, bool bVerbose, bclib::matrix & result, bclib::CRandom & oRandom); } #endif /* LHSCOMMONDEFINES_H */ lhs/src/akconst.cpp0000644000176200001440000000601014215223423013770 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(GaloisField & gf, int* kay, std::vector & b, std::vector & c, std::vector & k) { if (gf.q > 4) { throw std::runtime_error("Addelman Kempthorne designs not yet available for \n even q >4."); } *kay = 1; if (gf.q == 2) { b[1] = c[1] = k[1] = 1; } if (gf.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 < gf.u_q; i++) { k[i] = static_cast(i); } return 0; } int akodd(GaloisField & gf, int* kay, std::vector & b, std::vector & c, std::vector & k) { int num, den, four; if (gf.p != 3) { four = 4; } else { four = 1; } *kay = 0; for (size_t i = 2; i < gf.u_q; i++) { if (gf.root[i] == -1) { *kay = static_cast(i); } } if (*kay == 0) { throw std::runtime_error("Problem: no rootless element in GF\n"); } for (size_t i = 1; i < gf.u_q; i++) { num = gf.plus(*kay, gf.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/xtn.h0000644000176200001440000003367414215223424012625 0ustar liggesusers/* * NOTE: This file should be excluded from the Doxygen build ****** COMPUTER GENERATED etc/CreatePowerCylce.R ****** * * file xtn.h * author Robert Carnell * copyright Copyright (c) 2020, Robert Carnell * * License: MIT * * Reference: * * * This file is derived from the xtndispatch.h xtnset.h xtndeclare.h * See Table B.3 Power cycle II pg 316 in Block Designs: A Randomization Approach */ #ifndef XTN_H #define XTN_H // GF(2^2) = GF(4) // x^2 = 1 + x if (q == primes::ipow(2,2)) xtn = {1, 1}; // GF(2^3) = GF(8) // x^3 = 1 + x^2 else if (q == primes::ipow(2,3)) xtn = {1, 0, 1}; // GF(2^4) = GF(16) // x^4 = 1 + x^3 else if (q == primes::ipow(2,4)) xtn = {1, 0, 0, 1}; // GF(2^5) = GF(32) // x^5 = 1 + x^3 else if (q == primes::ipow(2,5)) xtn = {1, 0, 0, 1, 0}; // GF(2^6) = GF(64) // x^6 = 1 + x^5 else if (q == primes::ipow(2,6)) xtn = {1, 0, 0, 0, 0, 1}; // GF(2^7) = GF(128) // x^7 = 1 + x^6 else if (q == primes::ipow(2,7)) xtn = {1, 0, 0, 0, 0, 0, 1}; // GF(2^8) = GF(256) // x^8 = 1 + x^4 + x^5 + x^6 else if (q == primes::ipow(2,8)) xtn = {1, 0, 0, 0, 1, 1, 1, 0}; // GF(2^9) = GF(512) // x^9 = 1 + x^5 else if (q == primes::ipow(2,9)) xtn = {1, 0, 0, 0, 0, 1, 0, 0, 0}; // GF(2^10) = GF(1024) // x^10 = 1 + x^7 else if (q == primes::ipow(2,10)) xtn = {1, 0, 0, 0, 0, 0, 0, 1, 0, 0}; // GF(2^11) = GF(2048) // x^11 = 1 + x^9 else if (q == primes::ipow(2,11)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0}; // GF(2^12) = GF(4096) // x^12 = 1 + x^4 + x^10 + x^11 else if (q == primes::ipow(2,12)) xtn = {1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1}; // GF(2^13) = GF(8192) // x^13 = 1 + x^8 + x^11 + x^12 else if (q == primes::ipow(2,13)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1}; // GF(2^14) = GF(16384) // x^14 = 1 + x^2 + x^12 + x^13 else if (q == primes::ipow(2,14)) xtn = {1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1}; // GF(2^15) = GF(32768) // x^15 = 1 + x^14 else if (q == primes::ipow(2,15)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1}; // GF(2^16) = GF(65536) // x^16 = 1 + x^4 + x^13 + x^15 else if (q == primes::ipow(2,16)) xtn = {1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1}; // GF(2^17) = GF(131072) // x^17 = 1 + x^14 else if (q == primes::ipow(2,17)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0}; // GF(2^18) = GF(262144) // x^18 = 1 + x^11 else if (q == primes::ipow(2,18)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0}; // GF(2^19) = GF(524288) // x^19 = 1 + x^14 + x^17 + x^18 else if (q == primes::ipow(2,19)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1}; // GF(2^20) = GF(1048576) // x^20 = 1 + x^17 else if (q == primes::ipow(2,20)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0}; // GF(2^21) = GF(2097152) // x^21 = 1 + x^19 else if (q == primes::ipow(2,21)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0}; // GF(2^22) = GF(4194304) // x^22 = 1 + x^21 else if (q == primes::ipow(2,22)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1}; // GF(2^23) = GF(8388608) // x^23 = 1 + x^18 else if (q == primes::ipow(2,23)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0}; // GF(2^24) = GF(16777216) // x^24 = 1 + x^17 + x^22 + x^23 else if (q == primes::ipow(2,24)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1}; // GF(2^25) = GF(33554432) // x^25 = 1 + x^22 else if (q == primes::ipow(2,25)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0}; // GF(2^26) = GF(67108864) // x^26 = 1 + x^20 + x^24 + x^25 else if (q == primes::ipow(2,26)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1}; // GF(2^27) = GF(134217728) // x^27 = 1 + x^22 + x^25 + x^26 else if (q == primes::ipow(2,27)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1}; // GF(2^28) = GF(268435456) // x^28 = 1 + x^25 else if (q == primes::ipow(2,28)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0}; // GF(2^29) = GF(536870912) // x^29 = 1 + x^27 else if (q == primes::ipow(2,29)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0}; // GF(3^2) = GF(9) // x^2 = 1 + 2x else if (q == primes::ipow(3,2)) xtn = {1, 2}; // GF(3^3) = GF(27) // x^3 = 2 + x^2 else if (q == primes::ipow(3,3)) xtn = {2, 0, 1}; // GF(3^4) = GF(81) // x^4 = 1 + 2x^3 else if (q == primes::ipow(3,4)) xtn = {1, 0, 0, 2}; // GF(3^5) = GF(243) // x^5 = 2 + 2x^2 + 2x^4 else if (q == primes::ipow(3,5)) xtn = {2, 0, 2, 0, 2}; // GF(3^6) = GF(729) // x^6 = 1 + 2x^5 else if (q == primes::ipow(3,6)) xtn = {1, 0, 0, 0, 0, 2}; // GF(3^7) = GF(2187) // x^7 = 2 + 2x^4 + 2x^6 else if (q == primes::ipow(3,7)) xtn = {2, 0, 0, 0, 2, 0, 2}; // GF(3^8) = GF(6561) // x^8 = 1 + 2x^5 else if (q == primes::ipow(3,8)) xtn = {1, 0, 0, 0, 0, 2, 0, 0}; // GF(3^9) = GF(19683) // x^9 = 2 + 2x^5 + 2x^7 else if (q == primes::ipow(3,9)) xtn = {2, 0, 0, 0, 0, 2, 0, 2, 0}; // GF(3^10) = GF(59049) // x^10 = 1 + 2x^7 + 2x^9 else if (q == primes::ipow(3,10)) xtn = {1, 0, 0, 0, 0, 0, 0, 2, 0, 2}; // GF(3^11) = GF(177147) // x^11 = 2 + 2x^4 + 2x^10 else if (q == primes::ipow(3,11)) xtn = {2, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2}; // GF(3^12) = GF(531441) // x^12 = 1 + 2x^7 + 2x^11 else if (q == primes::ipow(3,12)) xtn = {1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 2}; // GF(3^13) = GF(1594323) // x^13 = 2 + 2x^6 + 2x^12 else if (q == primes::ipow(3,13)) xtn = {2, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 2}; // GF(3^14) = GF(4782969) // x^14 = 1 + 2x^13 else if (q == primes::ipow(3,14)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2}; // GF(3^15) = GF(14348907) // x^15 = 2 + 2x^4 + 2x^14 else if (q == primes::ipow(3,15)) xtn = {2, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2}; // GF(3^16) = GF(43046721) // x^16 = 1 + 2x^9 else if (q == primes::ipow(3,16)) xtn = {1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0}; // GF(3^17) = GF(129140163) // x^17 = 2 + 2x^8 + 2x^16 else if (q == primes::ipow(3,17)) xtn = {2, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 2}; // GF(3^18) = GF(387420489) // x^18 = 1 + 2x^5 + 2x^17 else if (q == primes::ipow(3,18)) xtn = {1, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2}; // GF(5^2) = GF(25) // x^2 = 3 + 4x else if (q == primes::ipow(5,2)) xtn = {3, 4}; // GF(5^3) = GF(125) // x^3 = 3 + 4x^2 else if (q == primes::ipow(5,3)) xtn = {3, 0, 4}; // GF(5^4) = GF(625) // x^4 = 2 + 4x + 4x^3 else if (q == primes::ipow(5,4)) xtn = {2, 4, 0, 4}; // GF(5^5) = GF(3125) // x^5 = 3 + 4x^2 else if (q == primes::ipow(5,5)) xtn = {3, 0, 4, 0, 0}; // GF(5^6) = GF(15625) // x^6 = 3 + 4x^5 else if (q == primes::ipow(5,6)) xtn = {3, 0, 0, 0, 0, 4}; // GF(5^7) = GF(78125) // x^7 = 3 + 4x^6 else if (q == primes::ipow(5,7)) xtn = {3, 0, 0, 0, 0, 0, 4}; // GF(5^8) = GF(390625) // x^8 = 2 + 4x^3 + 4x^5 else if (q == primes::ipow(5,8)) xtn = {2, 0, 0, 4, 0, 4, 0, 0}; // GF(5^9) = GF(1953125) // x^9 = 2 + 4x^6 + 4x^7 else if (q == primes::ipow(5,9)) xtn = {2, 0, 0, 0, 0, 0, 4, 4, 0}; // GF(5^10) = GF(9765625) // x^10 = 2 + 4x^7 + 4x^9 else if (q == primes::ipow(5,10)) xtn = {2, 0, 0, 0, 0, 0, 0, 4, 0, 4}; // GF(5^11) = GF(48828125) // x^11 = 3 + 4x^10 else if (q == primes::ipow(5,11)) xtn = {3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4}; // GF(5^12) = GF(244140625) // x^12 = 2 + 4x^4 + 4x^7 else if (q == primes::ipow(5,12)) xtn = {2, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0}; // GF(7^2) = GF(49) // x^2 = 4 + 6x else if (q == primes::ipow(7,2)) xtn = {4, 6}; // GF(7^3) = GF(343) // x^3 = 5 + 6x + 6x^2 else if (q == primes::ipow(7,3)) xtn = {5, 6, 6}; // GF(7^4) = GF(2401) // x^4 = 4 + 6x^2 + 6x^3 else if (q == primes::ipow(7,4)) xtn = {4, 0, 6, 6}; // GF(7^5) = GF(16807) // x^5 = 3 + 6x^4 else if (q == primes::ipow(7,5)) xtn = {3, 0, 0, 0, 6}; // GF(7^6) = GF(117649) // x^6 = 4 + 6x^4 + 6x^5 else if (q == primes::ipow(7,6)) xtn = {4, 0, 0, 0, 6, 6}; // GF(7^7) = GF(823543) // x^7 = 3 + 6x^5 else if (q == primes::ipow(7,7)) xtn = {3, 0, 0, 0, 0, 6, 0}; // GF(7^8) = GF(5764801) // x^8 = 4 + 6x^7 else if (q == primes::ipow(7,8)) xtn = {4, 0, 0, 0, 0, 0, 0, 6}; // GF(7^9) = GF(40353607) // x^9 = 5 + 6x^3 + 6x^8 else if (q == primes::ipow(7,9)) xtn = {5, 0, 0, 6, 0, 0, 0, 0, 6}; // GF(7^10) = GF(282475249) // x^10 = 4 + 6x^8 + 6x^9 else if (q == primes::ipow(7,10)) xtn = {4, 0, 0, 0, 0, 0, 0, 0, 6, 6}; // GF(11^2) = GF(121) // x^2 = 4 + 10x else if (q == primes::ipow(11,2)) xtn = {4, 10}; // GF(11^3) = GF(1331) // x^3 = 6 + 10x^2 else if (q == primes::ipow(11,3)) xtn = {6, 0, 10}; // GF(11^4) = GF(14641) // x^4 = 9 + 10x else if (q == primes::ipow(11,4)) xtn = {9, 10, 0, 0}; // GF(11^5) = GF(161051) // x^5 = 2 + 10x^2 + 10x^3 else if (q == primes::ipow(11,5)) xtn = {2, 0, 10, 10, 0}; // GF(11^6) = GF(1771561) // x^6 = 4 + 10x + 10x^5 else if (q == primes::ipow(11,6)) xtn = {4, 10, 0, 0, 0, 10}; // GF(11^7) = GF(19487171) // x^7 = 6 + 10x^6 else if (q == primes::ipow(11,7)) xtn = {6, 0, 0, 0, 0, 0, 10}; // GF(11^8) = GF(214358881) // x^8 = 9 + 10x + 10x^4 else if (q == primes::ipow(11,8)) xtn = {9, 10, 0, 0, 10, 0, 0, 0}; // GF(13^2) = GF(169) // x^2 = 11 + 12x else if (q == primes::ipow(13,2)) xtn = {11, 12}; // GF(13^3) = GF(2197) // x^3 = 6 + 12x^2 else if (q == primes::ipow(13,3)) xtn = {6, 0, 12}; // GF(13^4) = GF(28561) // x^4 = 11 + 12x + 12x^3 else if (q == primes::ipow(13,4)) xtn = {11, 12, 0, 12}; // GF(13^5) = GF(371293) // x^5 = 2 + 12x + 12x^3 else if (q == primes::ipow(13,5)) xtn = {2, 12, 0, 12, 0}; // GF(13^6) = GF(4826809) // x^6 = 7 + 12x^3 + 12x^5 else if (q == primes::ipow(13,6)) xtn = {7, 0, 0, 12, 0, 12}; // GF(13^7) = GF(62748517) // x^7 = 7 + 12x^4 else if (q == primes::ipow(13,7)) xtn = {7, 0, 0, 0, 12, 0, 0}; // GF(13^8) = GF(815730721) // x^8 = 11 + 12x^5 + 12x^6 else if (q == primes::ipow(13,8)) xtn = {11, 0, 0, 0, 0, 12, 12, 0}; // GF(17^2) = GF(289) // x^2 = 14 + 16x else if (q == primes::ipow(17,2)) xtn = {14, 16}; // GF(17^3) = GF(4913) // x^3 = 3 + 16x else if (q == primes::ipow(17,3)) xtn = {3, 16, 0}; // GF(17^4) = GF(83521) // x^4 = 12 + 16x^3 else if (q == primes::ipow(17,4)) xtn = {12, 0, 0, 16}; // GF(17^5) = GF(1419857) // x^5 = 3 + 16x^4 else if (q == primes::ipow(17,5)) xtn = {3, 0, 0, 0, 16}; // GF(17^6) = GF(24137569) // x^6 = 14 + 16x^5 else if (q == primes::ipow(17,6)) xtn = {14, 0, 0, 0, 0, 16}; // GF(17^7) = GF(410338673) // x^7 = 3 + 16x^3 else if (q == primes::ipow(17,7)) xtn = {3, 0, 0, 16, 0, 0, 0}; // GF(19^2) = GF(361) // x^2 = 17 + 18x else if (q == primes::ipow(19,2)) xtn = {17, 18}; // GF(19^3) = GF(6859) // x^3 = 3 + 18x^2 else if (q == primes::ipow(19,3)) xtn = {3, 0, 18}; // GF(19^4) = GF(130321) // x^4 = 17 + 18x^3 else if (q == primes::ipow(19,4)) xtn = {17, 0, 0, 18}; // GF(19^5) = GF(2476099) // x^5 = 3 + 18x else if (q == primes::ipow(19,5)) xtn = {3, 18, 0, 0, 0}; // GF(19^6) = GF(47045881) // x^6 = 16 + 18x else if (q == primes::ipow(19,6)) xtn = {16, 18, 0, 0, 0, 0}; // GF(19^7) = GF(893871739) // x^7 = 10 + 18x^5 else if (q == primes::ipow(19,7)) xtn = {10, 0, 0, 0, 0, 18, 0}; // GF(23^2) = GF(529) // x^2 = 16 + 22x else if (q == primes::ipow(23,2)) xtn = {16, 22}; // GF(23^3) = GF(12167) // x^3 = 7 + 22x^2 else if (q == primes::ipow(23,3)) xtn = {7, 0, 22}; // GF(23^4) = GF(279841) // x^4 = 12 + 22x else if (q == primes::ipow(23,4)) xtn = {12, 22, 0, 0}; // GF(23^5) = GF(6436343) // x^5 = 5 + 22x^4 else if (q == primes::ipow(23,5)) xtn = {5, 0, 0, 0, 22}; // GF(23^6) = GF(148035889) // x^6 = 16 + 22x^5 else if (q == primes::ipow(23,6)) xtn = {16, 0, 0, 0, 0, 22}; // GF(29^2) = GF(841) // x^2 = 26 + 28x else if (q == primes::ipow(29,2)) xtn = {26, 28}; // GF(29^3) = GF(24389) // x^3 = 11 + 28x else if (q == primes::ipow(29,3)) xtn = {11, 28, 0}; // GF(29^4) = GF(707281) // x^4 = 27 + 28x^3 else if (q == primes::ipow(29,4)) xtn = {27, 0, 0, 28}; // GF(29^5) = GF(20511149) // x^5 = 3 + 28x^3 else if (q == primes::ipow(29,5)) xtn = {3, 0, 0, 28, 0}; // GF(29^6) = GF(594823321) // x^6 = 26 + 28x else if (q == primes::ipow(29,6)) xtn = {26, 28, 0, 0, 0, 0}; // GF(31^2) = GF(961) // x^2 = 19 + 30x else if (q == primes::ipow(31,2)) xtn = {19, 30}; // GF(31^3) = GF(29791) // x^3 = 3 + 30x else if (q == primes::ipow(31,3)) xtn = {3, 30, 0}; // GF(31^4) = GF(923521) // x^4 = 18 + 30x^3 else if (q == primes::ipow(31,4)) xtn = {18, 0, 0, 30}; // GF(31^5) = GF(28629151) // x^5 = 11 + 30x^3 else if (q == primes::ipow(31,5)) xtn = {11, 0, 0, 30, 0}; // GF(31^6) = GF(887503681) // x^6 = 19 + 30x^5 else if (q == primes::ipow(31,6)) xtn = {19, 0, 0, 0, 0, 30}; // GF(37^2) = GF(1369) // x^2 = 32 + 36x else if (q == primes::ipow(37,2)) xtn = {32, 36}; // GF(37^3) = GF(50653) // x^3 = 13 + 36x^2 else if (q == primes::ipow(37,3)) xtn = {13, 0, 36}; // GF(37^4) = GF(1874161) // x^4 = 35 + 36x else if (q == primes::ipow(37,4)) xtn = {35, 36, 0, 0}; // GF(37^5) = GF(69343957) // x^5 = 5 + 36x else if (q == primes::ipow(37,5)) xtn = {5, 36, 0, 0, 0}; // GF(41^2) = GF(1681) // x^2 = 29 + 40x else if (q == primes::ipow(41,2)) xtn = {29, 40}; // GF(41^3) = GF(68921) // x^3 = 6 + 40x else if (q == primes::ipow(41,3)) xtn = {6, 40, 0}; // GF(41^4) = GF(2825761) // x^4 = 24 + 40x else if (q == primes::ipow(41,4)) xtn = {24, 40, 0, 0}; // GF(41^5) = GF(115856201) // x^5 = 6 + 40x^4 else if (q == primes::ipow(41,5)) xtn = {6, 0, 0, 0, 40}; // GF(43^2) = GF(1849) // x^2 = 40 + 42x else if (q == primes::ipow(43,2)) xtn = {40, 42}; // GF(43^3) = GF(79507) // x^3 = 3 + 42x else if (q == primes::ipow(43,3)) xtn = {3, 42, 0}; // GF(43^4) = GF(3418801) // x^4 = 23 + 42x else if (q == primes::ipow(43,4)) xtn = {23, 42, 0, 0}; // GF(43^5) = GF(147008443) // x^5 = 3 + 42x^4 else if (q == primes::ipow(43,5)) xtn = {3, 0, 0, 0, 42}; // GF(47^2) = GF(2209) // x^2 = 34 + 46x else if (q == primes::ipow(47,2)) xtn = {34, 46}; // GF(47^3) = GF(103823) // x^3 = 5 + 46x^2 else if (q == primes::ipow(47,3)) xtn = {5, 0, 46}; // GF(47^4) = GF(4879681) // x^4 = 42 + 46x^3 else if (q == primes::ipow(47,4)) xtn = {42, 0, 0, 46}; // GF(47^5) = GF(229345007) // x^5 = 5 + 46x else if (q == primes::ipow(47,5)) xtn = {5, 46, 0, 0, 0}; #endif lhs/src/COrthogonalArray.cpp0000644000176200001440000002731414215223423015556 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; m_return_code = SUCCESS_CHECK; m_warning_msg = ""; m_randomClass = RUnif(); } void COrthogonalArray::createGaloisField(int q) { m_gf = GaloisField(q); } 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; } if (k > maxColumns) { std::ostringstream msg; msg << "At most " << maxColumns << " columns are possible for the design."; ostringstream_runtime_error(msg); } return k; } void COrthogonalArray::checkResult(int result, int nvalue, int * n) { if (result == SUCCESS_CHECK) { *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); if (k == 2 * q + 1) { std::ostringstream msg; msg << "\n\tWarning: The Addelman-Kempthorne construction with ncol = 2q+1\n"; msg << "\thas a defect. While it is still an OA(2q^2,2q+1,q,2),\n"; msg << "\tthere exist some pairs of rows that agree in three columns.\n"; msg << "\tThe final column in the array is involved in all of these\n"; msg << "\ttriple coincidences.\n"; m_warning_msg = msg.str(); m_return_code = WARNING_CHECK; } else { m_return_code = SUCCESS_CHECK; m_warning_msg = ""; } 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_return_code = SUCCESS_CHECK; m_warning_msg = ""; m_q = q; m_ncol = k; m_nrow = *n; } void COrthogonalArray::addelkempn(int akn, int q, int k, int* n) { 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_return_code = SUCCESS_CHECK; m_warning_msg = ""; m_q = q; m_ncol = k; m_nrow = *n; } 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_return_code = SUCCESS_CHECK; m_warning_msg = ""; m_q = q; m_ncol = k; m_nrow = *n; } void COrthogonalArray::bosebush(int q, int k, int *n) { if (q % 2 != 0) { 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 + 1); int q_star = 2 * q; createGaloisField(q_star); 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); if (k == 2 * q + 1) { std::ostringstream msg; msg << "\n\tWarning: The Bose-Bush construction with ncol = 2q+1\n"; msg << "\thas a defect. While it is still an OA(2q^2,2q+1,q,2),\n"; msg << "\tthere exist some pairs of rows that agree in three columns.\n\n"; m_warning_msg = msg.str(); m_return_code = WARNING_CHECK; } else { m_return_code = SUCCESS_CHECK; m_warning_msg = ""; } 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 + 1); primes::primepow(lambda, &pl, &nl, &isppl); primes::primepow(q , &pq, &nq, &isppq); if (isppq == 0) { throw std::runtime_error("The Bose-Bush design requires that q be prime raised to a positive integral power."); } if (isppl == 0) { 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); if (k == lambda * q + 1) { std::ostringstream msg; msg << "\n\tWarning: The Bose-Bush construction with ncol = lambda*q+1\n"; msg << "\thas a defect. While it is still an OA(lambda*q^2,lambda*q+1,q,2),\n"; msg << "\tit may have worse coincidence properties than\n"; msg << "\tOA(lambda*q^2,lambda*q+1,q,2).\n"; m_warning_msg = msg.str(); m_return_code = WARNING_CHECK; } else { m_return_code = SUCCESS_CHECK; m_warning_msg = ""; } 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; int str = 3; m_A = bclib::matrix(matrows, k); checkDesignMemory(); int result = oaconstruct::bush(m_gf, m_A, str, k); checkResult(result, q*q*q, n); if (str >= q + 1) { std::ostringstream msg; msg << "\tBush's (1952) theorem has a condition t(primes::ipow(q,str), k); checkDesignMemory(); int result = oaconstruct::bush(m_gf, m_A, str, k); checkResult(result, primes::ipow(q,str), n); m_return_code = SUCCESS_CHECK; m_warning_msg = ""; 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 += static_cast(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 != 0 && 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 += static_cast((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 != 0) { 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/CRandom.h0000644000176200001440000000622014215223422013320 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/randomLHS.cpp0000644000176200001440000001061714215223423014165 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(static_cast(n)*static_cast(k)); // need to cast before multiply to prevent integer overflow 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/Makevars0000644000176200001440000000004614347355417013340 0ustar liggesusersPKG_CPPFLAGS=-DRCOMPILE CXX_STD=CXX11 lhs/src/rutils.cpp0000644000176200001440000000225014215223424013653 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/oa_r_utils.h0000644000176200001440000000736413421432010014140 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/oalibVersion.h0000644000176200001440000000177414215223424014444 0ustar liggesusers/** * @file oalibVersion.h * @author Robert Carnell * @copyright Copyright (c) 2020, 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 OALIBVERSION_H #define OALIBVERSION_H namespace oacpp { inline static const char * getVersion() {return "1.1.0";} } #endif lhs/src/lhs_r_utilities.h0000644000176200001440000001243013422723613015205 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/runif.h0000644000176200001440000000703314215223424013125 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 { /** Default Constructor */ SeedSet() {}; /** Constructor */ SeedSet(int one, int two, int three, int four) { is = one; js = two; ks = three; ls = four; }; /** 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); ~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; std::vector u; double c, cd, cm; }; } #endif lhs/src/rutils.h0000644000176200001440000001232314215223424013322 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/oalhs_r.cpp0000644000176200001440000000770213417516247014002 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/lhs_r.cpp0000644000176200001440000002334114347355130013452 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 . */ /* * A Note about Rcpp::RNGScope (3/25/2020) * * In the original code, Rcpp::RNGScope was called before memory was allocated * for the return SEXP. In rare cases, the RNGScope destructor caused a * garbage collection event at the end of the function call, at the same time * the return value was being unprotected causing the return value to be * garbage collected. * * Thanks to @mb706 for reporting this issue on github (https://github.com/bertcarnell/lhs/issues/21) * Thanks also the r-help community for suggesting solutions * http://lists.r-forge.r-project.org/pipermail/rcpp-devel/2013-May/005838.html * * There were 5 possible solutions: * 1. Refactor the code into a sub function to allow return value protection (mixes * Rcpp code with base C code) * 2. call all memory allocations before RGNState (seems fragile to future changes) * 3. Use Rcpp attributes (didn't want to preprocess) * 4. split the GetRNGState and PutRNGState calls (calls back to C functions) * 5. Call the destructor on RNGState explicitly */ #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"); } 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); bclib::matrix intMat = bclib::matrix(m_n, m_k); Rcpp::NumericMatrix result; START_RNG lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { result = lhs_r::degenerateCase(m_k, oRStandardUniform); } else { try { lhslib::improvedLHS(m_n, m_k, m_dup, intMat, oRStandardUniform); } catch (...) { END_RNG throw; } result = lhs_r::convertIntegerToNumericLhs(intMat); } END_RNG 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"); } 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); bclib::matrix intMat = bclib::matrix(m_n, m_k); Rcpp::NumericMatrix result; START_RNG lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { result = lhs_r::degenerateCase(m_k, oRStandardUniform); } else { try { lhslib::maximinLHS(m_n, m_k, m_dup, intMat, oRStandardUniform); } catch (...) { END_RNG throw; } result = lhs_r::convertIntegerToNumericLhs(intMat); } END_RNG 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); bclib::matrix intMat = bclib::matrix(m_n, m_k); int jLen = static_cast(::Rf_choose(static_cast(m_n), 2.0) + 1.0); Rcpp::NumericMatrix result; START_RNG lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { result = lhs_r::degenerateCase(m_k, oRStandardUniform); } else { try { lhslib::optimumLHS(m_n, m_k, m_maxsweeps, m_eps, intMat, jLen, oRStandardUniform, m_bVerbose); } catch (...) { END_RNG throw; } result = lhs_r::convertIntegerToNumericLhs(intMat); } END_RNG 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); 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"); } int m_n = Rcpp::as(n); int m_k = Rcpp::as(k); bool bPreserveDraw = Rcpp::as(preserveDraw); lhs_r::checkArguments(m_n, m_k); bclib::matrix result = bclib::matrix(m_n, m_k); Rcpp::NumericMatrix rresult; START_RNG lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { rresult = lhs_r::degenerateCase(m_k, oRStandardUniform); } else { try { lhslib::randomLHS(m_n, m_k, bPreserveDraw, result, oRStandardUniform); } catch (...) { END_RNG throw; } rresult = Rcpp::NumericMatrix(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); } } } END_RNG 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 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); bclib::matrix mat = bclib::matrix(m_n, m_k); Rcpp::NumericMatrix rresult; START_RNG lhs_r::RStandardUniform oRStandardUniform = lhs_r::RStandardUniform(); if (m_n == 1) { rresult = lhs_r::degenerateCase(m_k, oRStandardUniform); } else { try { lhslib::geneticLHS(m_n, m_k, m_pop, m_gen, m_pMut, m_criterium, m_bVerbose, mat, oRStandardUniform); } catch (...) { END_RNG throw; } rresult = Rcpp::NumericMatrix(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); } } } END_RNG return rresult; END_RCPP } RcppExport SEXP get_library_versions(void) { BEGIN_RCPP Rcpp::CharacterVector rresult = Rcpp::CharacterVector(1); std::string bclibVersion = bclib::getVersion(); std::string oalibVersion = oacpp::getVersion(); std::string lhslibVersion = lhslib::getVersion(); rresult[0] = std::string("bclib: ") + bclibVersion + " oalib: " + oalibVersion + " lhslib: " + lhslibVersion; return rresult; END_RCPP } lhs/src/lhslibVersion.h0000644000176200001440000000177714215223423014635 0ustar liggesusers/** * @file lhslibVersion.h * @author Robert Carnell * @copyright Copyright (c) 2020, 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 LHSLIBVERSION_H #define LHSLIBVERSION_H namespace lhslib { inline static const char * getVersion() {return "1.0.1";} } #endif lhs/src/Makevars.win0000644000176200001440000000005014115746173014123 0ustar liggesusersPKG_CPPFLAGS=-DRCOMPILE CXX_STD=CXX11 lhs/src/construct.cpp0000644000176200001440000003243414215223423014363 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"; ostringstream_runtime_error(msg); } if (ncol <= 0) { msg << "Nonpositive number of columns requested for Bose's design\n"; ostringstream_runtime_error(msg); } return SUCCESS_CHECK; } int bose(GaloisField & gf, bclib::matrix & A, int ncol) { size_t icol, irow; // bosecheck throws if it fails bosecheck(gf.q, ncol); irow = 0; for (size_t i = 0; i < gf.u_q; i++) { for (size_t j = 0; j < gf.u_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(GaloisField & 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"; ostringstream_runtime_error(msg); } if (str > ncol) { msg << "It doesn't make sense to have an array of strength " << str << " with only " << ncol << "columns.\n"; ostringstream_runtime_error(msg); } return SUCCESS_CHECK; } int bush(GaloisField & gf, bclib::matrix & A, int str, int ncol) { std::vector coef(str); // bushcheck throws if it fails bushcheck(gf.q, str, ncol); size_t qToStr = static_cast(primes::ipow(gf.q, str)); for (size_t i = 0; i < qToStr; i++) { itopoly(static_cast(i), gf.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"; ostringstream_runtime_error(msg); } 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"; ostringstream_runtime_error(msg); } return SUCCESS_CHECK; } int addelkemp(GaloisField & gf, bclib::matrix & A, int ncol) { int kay; /* A&K notation */ int square, ksquare, temp; size_t row, col; size_t u_ncol = static_cast(ncol); std::vector b(gf.u_q); std::vector c(gf.u_q); std::vector k(gf.u_q); // addelkempcheck throws if it fails addelkempcheck(gf.q, gf.p, ncol); for (size_t i = 0; i < gf.u_q; i++) { /* First q*q rows */ square = gf.times(i,i); for (size_t j = 0; j < gf.u_q; j++) { row = i * gf.u_q + j; col = 0; if (col < u_ncol) { A(row, col++) = static_cast(j); } for (size_t m = 1; m < gf.u_q && col < u_ncol; m++) { A(row,col++) = gf.plus(i,gf.times(m,j)); } for (size_t m = 0; m < gf.u_q && col < u_ncol; m++) { temp = gf.plus(j,gf.times(m,i)); A(row,col++) = gf.plus(temp,square); /* Rgt cols */ } if (col < u_ncol) { A(row, col++) = static_cast(i); } } } if (gf.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 < gf.u_q; i++) { /* Second q*q rows */ square = gf.times(i,i); ksquare = gf.times(kay,square); for (size_t j = 0; j < gf.u_q; j++) { row = gf.u_q * gf.u_q + i * gf.u_q + j; col = 0; if (col < u_ncol) { A(row, col++) = static_cast(j); } for (size_t m = 1; m < gf.u_q && col < u_ncol; m++, col++) { A(row,col) = gf.plus(A(row - gf.u_q * gf.u_q, col), b[m]); } if (col < u_ncol) { A(row,col++) = gf.plus(ksquare,j); /* q+1 */ } for (size_t m = 1; m < gf.u_q && col < u_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 < u_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"; ostringstream_runtime_error(msg); } 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"; ostringstream_runtime_error(msg); } return SUCCESS_CHECK; } int bosebush(GaloisField & gf, bclib::matrix & B, int ncol) { int mul; size_t irow; size_t u_ncol = static_cast(ncol); size_t q_star = gf.u_q; size_t s = q_star / 2; // s is the same as q since q_star = 2 * q bclib::matrix A(s, q_star); // bosebushcheck throws if it fails bosebushcheck(static_cast(s), gf.p, ncol); irow = 0; for (size_t i = 0; i < q_star; i++) { for (size_t j = 0; j < q_star; 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++) { // the original code has this j < ncol && j < 2*s+1 // however, A has dimensions of [s,2*q] so this must stop at either the number of columns or 2*q // for (size_t j = 0; j < u_ncol && j < 2 * s + 1; j++) for (size_t j = 0; j < u_ncol && j < 2 * s; j++) { B(irow,j) = A(k,j); } if (u_ncol == 2 * s + 1) { B(irow, u_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) == 0) { msg << "Bose Bush routine given a nonprime.\n"; ostringstream_runtime_error(msg); } 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"; ostringstream_runtime_error(msg); } return SUCCESS_CHECK; } int bosebushl(GaloisField & gf, int lam, bclib::matrix & B, int ncol) /* Implement Bose and Bush's 1952 A.M.S. method with given lambda */ { int irow; int mul; size_t u_ncol = static_cast(ncol); size_t s = gf.u_q / lam; /* number of levels in design */ bclib::matrix A(s, gf.u_q); // bosebushlcheck throws if it fails bosebushlcheck(static_cast(s), gf.p, lam, ncol); irow = 0; for (size_t i = 0; i < gf.u_q; i++) { for (size_t j = 0; j < gf.u_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 < u_ncol && j < lam * s + 1 && j < gf.u_q; j++) { B(irow,j) = A(k,j); } if (ncol == lam * static_cast(s) + 1) { B(irow, u_ncol - 1) = static_cast(i % s); } irow++; } } return SUCCESS_CHECK; } } // end namespace } // end namespace lhs/src/OACommonDefines.h0000644000176200001440000003332514215223423014752 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 /** * A macro to determine if warnings are printed or thrown as runtime_error */ #define PRINT_WARNINGS false #else /** * A print macro to enable printing with or without R */ #define PRINT_OUTPUT std::cout /** * A macro to determine if warnings are printed or thrown as runtime_error */ #define PRINT_WARNINGS true #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 /** * When a method returns an int to indicate a warning message */ #define WARNING_CHECK 2 namespace oacpp { /** * throw a runtime_error with a stringstream message * @param msg the error message * @throws std::runtime_error */ inline void ostringstream_runtime_error(const std::ostringstream & msg) { const std::string smsg = msg.str(); throw std::runtime_error(smsg.c_str()); } } /** * @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/runif.cpp0000644000176200001440000001167514215223424013467 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() : RUnif(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; u = std::vector(SEED_VECTOR_LENGTH); u.assign(SEED_VECTOR_LENGTH, 0.0); RUnif::seed(is, js, ks, 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; } 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 { std::ostringstream msg; msg << "Error: Invalid seed " << is << " " << js << " " << ks << " " << ls << "\n"; msg << "Must be four integers between 1 and 168, and\n"; msg << "must not all be 1.\n"; ostringstream_runtime_error(msg); } } SeedSet RUnif::getSeedSet() { SeedSet s = SeedSet(); 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) == SEEDBAD) { 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 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) == SEEDBAD) { 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 (size_t ii = 1; ii <= 97; ii++) { /* do 20 ii=1,97 */ s = 0.0; t = 0.5; for (size_t 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 (size_t ii = 1; ii <= static_cast(n); ii++) { /* ii do 40 ii=1,n */ uni = u[static_cast(ip)] - u[static_cast(jp)]; if (uni < 0.0) { uni = uni + 1.0; } u[static_cast(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/ak3.cpp0000644000176200001440000002367614215223423013025 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) { if (p == 2 && q > 4) { throw std::runtime_error("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"); } if (q == 8) { /* Moot */ throw std::runtime_error("This Addelman-Kempthorne OA(2*8^3,ncol,8,2) is experimental and not yet working."); } if (ncol > 2 * q * q + 2 * q + 1) { std::ostringstream msg; msg << "The Addelman-Kempthorne (n=3) construction needs ncol <= 2q^2+2q+1. Can't have ncol = " << ncol << " with q = " << q << "\n"; ostringstream_runtime_error(msg); } return SUCCESS_CHECK; } /* Implement Addelman and Kempthorne's 1961 A.M.S. method with n=3 */ int addelkemp3(GaloisField & gf, bclib::matrix & A, int ncol) { int kay; //std::vector b, c, k; /* A&K notation */ int square, ksquare; size_t row, col; size_t u_ncol = static_cast(ncol); // Throws on any error addelkemp3check(gf.q, gf.p, ncol); std::vector b(gf.u_q); std::vector c(gf.u_q); std::vector k(gf.u_q); for (size_t i1 = 0; i1 < gf.u_q; i1++) { /* First q^3 rows */ square = gf.times(i1,i1); for (size_t i2 = 0; i2 < gf.u_q; i2++) { for (size_t i3 = 0; i3 < gf.u_q; i3++) { row = i3 + gf.u_q * i2 + gf.u_q * gf.u_q * i1; col = 0; if (col < u_ncol) { A(row, col++) = static_cast(i2); /* y */ } for (size_t m1 = 1; m1 < gf.u_q && col < u_ncol; m1++) /* x + my */ { A(row,col++) = gf.plus(i1,gf.times(m1,i2)); } if (col < u_ncol) { A(row, col++) = static_cast(i3); /* z */ } for (size_t m2 = 1; m2 < gf.u_q && col < u_ncol; m2++) /* x + mz */ { A(row,col++) = gf.plus(i1,gf.times(m2,i3)); } for (size_t m2 = 1; m2 < gf.u_q && col < u_ncol; m2++) /* y + mz */ { A(row,col++) = gf.plus(i2,gf.times(m2,i3)); } for (size_t m1 = 1; m1 < gf.u_q && col < u_ncol; m1++) /* x + my + nz */ { for (size_t m2 = 1; m2 < gf.u_q && col < u_ncol; m2++) { A(row,col++) = gf.plus(i1,gf.plus(gf.times(m1,i2),gf.times(m2,i3))); } } for (size_t m1 = 0; m1 < gf.u_q && col < u_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 < gf.u_q && col < u_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 < gf.u_q && col < u_ncol; m1++) /* x^2 + mx + y + nz */ { for (size_t m2 = 1; m2 < gf.u_q && col < u_ncol; m2++) { A(row,col++) = gf.plus(square, gf.plus(i2, gf.plus( gf.times(m2,i3) , gf.times(m1,i1) ) ) ); } } if (col < u_ncol) { A(row, col++) = static_cast(i1); /* x */ } } } } if (gf.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 < gf.u_q; i1++) { /* Second q^3 rows */ square = gf.times(i1,i1); ksquare = gf.times(kay,square); for (size_t i2 = 0; i2 < gf.u_q; i2++) { for (size_t i3 = 0; i3 < gf.u_q; i3++) { row = i3 + gf.u_q * i2 + gf.u_q * gf.u_q * i1 + gf.u_q * gf.u_q * gf.u_q; col = 0; if (col < u_ncol) { A(row, col++) = static_cast(i2); /* y */ } for (size_t m1 = 1; m1 < gf.u_q && col < u_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 < u_ncol) { A(row,col++) = static_cast(i3); /* z */ } for (size_t m2 = 1; m2 < gf.u_q && col < u_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 < gf.u_q && col < u_ncol; m2++) /* y + mz */ { A(row,col++) = gf.plus(i2,gf.times(m2,i3)); } for (size_t m1 = 1; m1 < gf.u_q && col < u_ncol; m1++) /* x + my + nz + b(m) */ { for (size_t m2 = 1; m2 < gf.u_q && col < u_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 < gf.u_q && col < u_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 < gf.u_q && col < u_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 < gf.u_q && col < u_ncol; m1++) /* kx^2 + k(m)x + y + nz +c(m) */ { for (size_t m2 = 1; m2 < gf.u_q && col < u_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 < u_ncol) { A(row, col++) = static_cast(i1); /* x */ } } } } return 1; } } // end namespace } // end namespace lhs/src/RStandardUniform.h0000644000176200001440000000257413413300351015223 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/oa_r.h0000644000176200001440000001145514115430532012724 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); /** * Create a Galois Field object * @param q the number of symbols in the array * @return a List Galois field components */ RcppExport SEXP /*List*/ create_galois_field(SEXP /*int*/ q); /** * Multiplication in polynomial representation * * @param p modulus * @param n length of p1 and p2 * @param xton characteristic polynomial * @param p1 polynomial 1 * @param p2 polynomial 2 * @return the product of the polynomials */ RcppExport SEXP /*IntegerVector*/ poly_prod(SEXP /*int*/ p, SEXP /*int*/ n, SEXP /*int vector*/ xton, SEXP /*int vector*/ p1, SEXP /*int vector*/ p2); /** * Addition in polynomial representation * * @param p modulus * @param u the length of p1 and p2 * @param p1 polynomial 1 * @param p2 polynomial 2 * @return the sum of the polynomials */ RcppExport SEXP /*IntegerVector*/ poly_sum(SEXP /*int*/ p, SEXP /*int*/ n, SEXP /*int vector*/ p1, SEXP /*int vector*/ p2); /** * 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 */ RcppExport SEXP /*IntegerVector*/ poly2int(SEXP /*int*/ p, SEXP /*int*/ n, SEXP /*int vector*/ poly); 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/oa_r_utils.cpp0000644000176200001440000000303213417005044014467 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/oalhs_r.h0000644000176200001440000000407413417002432013430 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/primes.cpp0000644000176200001440000001000514215223423013624 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 = 1; // maybe uninitialized otherwise *p = *n = *isit = 0; if (q <= 1) { return; } if (isprime(q) != 0) { *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) == 0) // LCOV_EXCL_START { return; } // LCOV_EXCL_STOP while (true) { 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/order.h0000644000176200001440000000643414215223422013117 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/GaloisField.cpp0000644000176200001440000002402414215223423014515 0ustar liggesusers/** * @file GaloisField.cpp * @author Robert Carnell * @copyright Copyright (c) 2020, Robert Carnell * * License: MIT * * This class is based on the code by Art Owen in galdef.h, galois.h, xtnset.h, xtndispatch.h, xtndeclare.h * * 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 "GaloisField.h" namespace oacpp { std::vector GaloisField::initializePowerCycle(int q) { std::vector xtn; #include "xtn.h" return xtn; } void GaloisField::fillAllPolynomials() { assert(u_q > 0 && u_n > 0); // NOLINT poly = bclib::matrix(u_q, u_n); size_t click = 0; for (size_t i = 0; i < u_n; i++) { poly(0, i) = 0; } for (size_t i = 1; i < u_q; i++) { for (click = 0; poly(i - 1, click) == (p - 1); click++) { poly(i, click) = 0; } poly(i, click) = poly(i - 1, click) + 1; for (size_t j = click + 1; j < u_n; j++) { poly(i, j) = poly(i - 1, j); } } } void GaloisField::computeSumsAndProducts() { assert(u_n > 0 && u_q > 0); // NOLINT assert(poly.rowsize() == u_q && xton.size() == u_n && poly.colsize() == u_n); // NOLINT std::vector temppoly(u_n); plus = bclib::matrix(u_q, u_q); times = bclib::matrix(u_q, u_q); for (size_t i = 0; i < u_q; i++) { for (size_t j = 0; j < u_q; j++) { GaloisField::polySum(p, u_n, poly.getrow(i), poly.getrow(j), temppoly); plus(i, j) = GaloisField::poly2int(p, n, temppoly); GaloisField::polyProd(p, u_n, xton, poly.getrow(i), poly.getrow(j), temppoly); times(i, j) = GaloisField::poly2int(p, n, temppoly); } } } void GaloisField::computeMultiplicativeInverse() { assert(u_q > 0 && !times.isEmpty()); // NOLINT inv = std::vector(u_q); std::ostringstream msg; for (size_t i = 0; i < u_q; i++) { inv[i] = -1; for (size_t j = 0; j < u_q; j++) { if (times(i, j) == 1) { inv[i] = static_cast(j); } } if (i > 0 && 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"; ostringstream_runtime_error(msg); } // LCOV_EXCL_STOP } } void GaloisField::computeNegative() { assert(u_q > 0 && !plus.isEmpty()); // NOLINT neg = std::vector(u_q); std::ostringstream msg; for (size_t i = 0; i < u_q; i++) { neg[i] = -1; for (size_t j = 0; j < u_q; j++) { if (plus(i, j) == 0) { neg[i] = static_cast(j); } } if (i > 0 && 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"; ostringstream_runtime_error(msg); } // LCOV_EXCL_STOP } } void GaloisField::computeRoots() { assert(u_q > 0 && !times.isEmpty()); // NOLINT root = std::vector(u_q); for (size_t i = 0; i < u_q; i++) { root[i] = -1; for (size_t j = 0; j < u_q; j++) { if (times(j, j) == static_cast(i)) { root[i] = static_cast(j); } } } } GaloisField::GaloisField(int q) { this->q = q; this->p = 0; this->n = 0; int ispp = 0; std::ostringstream msg; u_q = static_cast(q); if (q < 1) { /* Impossible argument */ msg << "Field must have positive number of elements.\n"; ostringstream_runtime_error(msg); } if (q == 1) { /* Pointless argument */ msg << "Field with 1 element was requested. \n"; ostringstream_runtime_error(msg); } primes::primepow(q, &p, &n, &ispp); u_n = static_cast(n); if (ispp == 0) { msg << "q=" << q << " is not a prime power.\n"; ostringstream_runtime_error(msg); } if (primes::isprime(q) != 0) { xton = { 0 }; /* Could have tested p=q, or n=1 */ } else { xton = GaloisField::initializePowerCycle(q); } if (xton.empty()) { msg << "GF(" << q << ") = GF(" << p << "^" << n << ") is not\n"; msg << "included in this program. To add it, consider modifying gfields.c.\n"; ostringstream_runtime_error(msg); } // create a matrix containing all polynomials in the Galois Field fillAllPolynomials(); // fill sum and product tables of the Galois Field computeSumsAndProducts(); // compute multiplicative inverse polynomial index computeMultiplicativeInverse(); // compute negative index computeNegative(); // compute roots of polynomials computeRoots(); } GaloisField::GaloisField() { q = 0; p = 0; n = 0; u_n = 0; u_q = 0; } void GaloisField::polySum(int p, size_t u_n, const std::vector & p1, const std::vector & p2, std::vector & sum) { assert(p > 0 && u_n > 0); // NOLINT assert(p1.size() == u_n && p2.size() == u_n && sum.size() == u_n); // NOLINT for (size_t i = 0; i < u_n; i++) { sum[i] = (p1[i] + p2[i]) % p; } } void GaloisField::polyProd(int p, size_t u_n, const std::vector & xton, const std::vector & p1, const std::vector & p2, std::vector & prod) { assert(p > 0 && u_n > 0); // NOLINT assert(xton.size() == u_n && p1.size() == u_n && p2.size() == u_n && prod.size() == u_n); // NOLINT int n = static_cast(u_n); std::vector longprod(2 * u_n - 1); longprod.assign(2 * u_n - 1, 0); for (size_t i = 0; i < u_n; i++) { for (size_t j = 0; j < u_n; 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 < u_n; j++) { longprod[ui - u_n + j] += xton[j] * longprod[ui]; } } for (size_t i = 0; i < u_n; i++) { prod[i] = longprod[i] % p; } } int GaloisField::poly2int(int p, int n, const std::vector & poly) { assert(p > 0 && n > 0); // NOLINT assert(poly.size() == static_cast(n)); // NOLINT 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; } void GaloisField::print() // LCOV_EXCL_START { 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 (size_t i = 0; i < u_n - 1; i++) { PRINT_OUTPUT << xton[i] << ","; } PRINT_OUTPUT << xton[u_n - 1] << ")\n"; PRINT_OUTPUT << "\n\nGF(" << q << ") Polynomial coefficients:\n"; for (size_t i = 0; i < u_q; i++) { PRINT_OUTPUT << " " << i << " "; for (size_t j = 0; j < u_n; j++) { PRINT_OUTPUT << poly(i, j) << " "; } PRINT_OUTPUT << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Addition Table\n"; for (size_t i = 0; i < u_q; i++) { PRINT_OUTPUT << " "; for (size_t j = 0; j < u_q; j++) { PRINT_OUTPUT << " " << plus(i, j); } PRINT_OUTPUT << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Multiplication table\n"; for (size_t i = 0; i < u_q; i++) { PRINT_OUTPUT << " "; for (size_t j = 0; j < u_q; j++) { PRINT_OUTPUT << " " << times(i, j); } PRINT_OUTPUT << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Reciprocals\n"; for (size_t i = 1; i < u_q; i++) { PRINT_OUTPUT << " " << i << " " << inv[i] << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Negatives\n"; for (size_t i = 0; i < u_q; i++) { PRINT_OUTPUT << " " << i << " " << neg[i] << "\n"; } PRINT_OUTPUT << "\n\nGF(" << q << ") Square roots\n"; for (size_t i = 0; i < u_q; i++) { PRINT_OUTPUT << " " << i << " " << root[i] << "\n"; } } // LCOV_EXCL_STOP } lhs/src/oaLHS.cpp0000644000176200001440000003600514215223424013304 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 { /** matrix size type */ using msize_type = bclib::matrix::size_type; /** matrix column iterator */ using columnit = bclib::matrix::columnwise_iterator; /** vector iterator */ using viterator = std::vector::iterator; /** vector const iterator */ using vconstiterator = std::vector::const_iterator; /** vector size type */ using vsize_type = std::vector::size_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; 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 ? static_cast(ceil(sqrt((double) n / 2.0))) : static_cast(floor(sqrt((double) n / 2.0))); if (q_bosebush % 2 != 0) { 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/oa_r.cpp0000644000176200001440000002405014115430532013252 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()); } if (oa.getReturnCode() == WARNING_CHECK) { Rcpp::warning(oa.getMessage().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()); } if (oa.getReturnCode() == WARNING_CHECK) { Rcpp::warning(oa.getMessage().c_str()); } oarutils::convertToIntegerMatrix(oa.getoa(), rcppA); if (bRandomLocal) { oarutils::randomizeOA(rcppA, qlocal); } return rcppA; END_RCPP } RcppExport SEXP /*List*/ create_galois_field(SEXP /*int*/ q) { BEGIN_RCPP int qlocal = Rcpp::as(q); oacpp::GaloisField gf = oacpp::GaloisField(qlocal); /** prime modulus exponent q = p^n --- Polynomial vector length */ Rcpp::IntegerVector n = Rcpp::IntegerVector::create(gf.n); /** prime modulus q = p^n*/ Rcpp::IntegerVector p = Rcpp::IntegerVector::create(gf.p); /** the order of the field q = p^n --- field element vector length */ Rcpp::IntegerVector q = Rcpp::IntegerVector::create(gf.q); /** characteristic polynomial of length u_n */ Rcpp::IntegerVector xton(gf.xton.begin(), gf.xton.end()); /** Indicator of which row of poly is the multiplicative inverse of this row of length u_q */ Rcpp::IntegerVector inv(gf.inv.begin(), gf.inv.end()); /** row number of which row of poly is the negative (additive inverse) of this row of length u_q */ Rcpp::IntegerVector neg(gf.neg.begin(), gf.neg.end()); /** root */ Rcpp::IntegerVector root(gf.root.begin(), gf.root.end()); /** sum field of dimension u_q x u_q*/ Rcpp::IntegerMatrix plus(gf.q, gf.q); oarutils::convertToIntegerMatrix(gf.plus, plus); /** product field of dimension u_q x u_q*/ Rcpp::IntegerMatrix times(gf.q, gf.q); oarutils::convertToIntegerMatrix(gf.times, times); /** polynomial field of dimension u_q x u_n */ Rcpp::IntegerMatrix poly(gf.q, gf.n); oarutils::convertToIntegerMatrix(gf.poly, poly); Rcpp::List gf_S3 = Rcpp::List::create(n, p, q, xton, inv, neg, root, plus, times, poly); return gf_S3; END_RCPP } /** * Multiplication in polynomial representation * * @param p modulus * @param u_n length of p1 and p2 * @param xton characteristic polynomial * @param p1 polynomial 1 * @param p2 polynomial 2 * @param prod the product of the polynomials */ RcppExport SEXP /*IntegerVector*/ poly_prod(SEXP /*int*/ p, SEXP /*int*/ n, SEXP /*int vector*/ xton, SEXP /*int vector*/ p1, SEXP /*int vector*/ p2) { BEGIN_RCPP int plocal = Rcpp::as(p); int nlocal = Rcpp::as(n); size_t u_n = static_cast(nlocal); std::vector xton_ref = Rcpp::as >(xton); std::vector p1_ref = Rcpp::as >(p1); std::vector p2_ref = Rcpp::as >(p2); std::vector prod_ref = std::vector(p1_ref.size()); oacpp::GaloisField::polyProd(plocal, u_n, xton_ref, p1_ref, p2_ref, prod_ref); Rcpp::IntegerVector prod_res(prod_ref.begin(), prod_ref.end()); return prod_res; END_RCPP } /** * Addition in polynomial representation * * @param p modulus * @param u_n the length of p1 and p2 * @param p1 polynomial 1 * @param p2 polynomial 2 * @param sum the sum of the polynomials */ RcppExport SEXP /*IntegerVector*/ poly_sum(SEXP /*int*/ p, SEXP /*int*/ n, SEXP /*int vector*/ p1, SEXP /*int vector*/ p2) { BEGIN_RCPP int plocal = Rcpp::as(p); int nlocal = Rcpp::as(n); size_t u_n = static_cast(nlocal); std::vector p1_ref = Rcpp::as >(p1); std::vector p2_ref = Rcpp::as >(p2); std::vector sum_ref = std::vector(p1_ref.size()); oacpp::GaloisField::polySum(plocal, u_n, p1_ref, p2_ref, sum_ref); Rcpp::IntegerVector sum_res(sum_ref.begin(), sum_ref.end()); return sum_res; END_RCPP } /** * 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 */ RcppExport SEXP /*IntegerVector*/ poly2int(SEXP /*int*/ p, SEXP /*int*/ n, SEXP /*int vector*/ poly) { BEGIN_RCPP int plocal = Rcpp::as(p); int nlocal = Rcpp::as(n); std::vector poly_ref = Rcpp::as >(poly); Rcpp::IntegerVector res(1); res[0] = oacpp::GaloisField::poly2int(plocal, nlocal, poly_ref); return res; END_RCPP } lhs/src/oa.h0000644000176200001440000000674114215223423012405 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 10000000 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, const bclib::matrix & A, int* str, int verbose); /** * Check strength 0 * @param q * @param A * @param verbose * @return */ int OA_str0(int q, const bclib::matrix & A, int verbose); /** * Check strength 1 * @param q * @param A * @param verbose * @return */ int OA_str1(int q, const bclib::matrix & A, int verbose); /** * Check strength 2 * @param q * @param A * @param verbose * @return */ int OA_str2(int q, const bclib::matrix & A, int verbose); /** * Check strength 3 * @param q * @param A * @param verbose * @return */ int OA_str3(int q, const bclib::matrix & A, int verbose); /** * Check strength 4 * @param q * @param A * @param verbose * @return */ int OA_str4(int q, const bclib::matrix & A, int verbose); /** * Check an arbitrary strength * @param q * @param A * @param t * @param verbose * @return */ int OA_strt(int q, const bclib::matrix & A, int t, int verbose); } }// end namespace #endif lhs/vignettes/0000755000176200001440000000000014347415524013061 5ustar liggesuserslhs/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/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/lhs_faq.Rmd0000644000176200001440000002322613636661764015160 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, 10) 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/lhs_basics.Rmd0000644000176200001440000001717014204306507015635 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/NEWS0000644000176200001440000000762614341534227011557 0ustar liggesusersChanges in version 0.1 (2006-07-11) - Initial release Changes in version 0.2 (2006-07-21) - 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. Changes in version 0.3 (2006-10-22) - 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. Changes in version 0.4 - Changed the license to GPL >= 2 according to a Kurt Hornik email Changes in version 0.5 (2009-01-26) - Change output filenames to be portable Changes in version 0.6 - Added a new option to randomLHS to allow for similar lhs's when the seed is set and columns are added Changes in version 0.7 (2012-03-27) - Removed test directories to fix them for the proper package structure. Changes in version 0.8 (2012-07-11) - 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. Changes in version 0.9 - Removed non-portable code introduced in Version 0.8 Changes in version 0.10 (2012-07-13) - Changed static template method definitions to be included in the definition of the utilityLHS class, instead of in the header below the class. Changes in 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. Changes in version 0.12 (2016-01-15) - Fixed a bug in the Description file. Changes in version 0.13 (2016-01-18) - 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. Changes in version 0.14 (2016-08-09) - Fixed a bug suggested by Roland Lowe on 8/4/2016. Changes in version 0.15 (2017-12-20) - Added registration of native routines. Changes in version 0.16 (2018-01-04) - 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) Changes in version 1.0 (2019-01-31) - Major revision. - Changed all underlying C code to C++ using Rcpp. - Added orthogonal array latin hypercube capability Changes in version 1.0.1 (2019-02-03) - Update to fix a memory leak noticed on CRAN servers when checking examples with valgrind Changes in version 1.0.2 (2020-04-13) - Added references to the Orthogonal array functions - Fixed typos - Changed the way the Rcpp::RNGScope object is destructed based on the debugging efforts of @mb706 Changes in version 1.1.0 (2020-09-29) - Bug reports from Dr. Ulrike Groemping (https://github.com/bertcarnell/lhs/issues/26, https://github.com/bertcarnell/lhs/issues/25) - Fixed underlying C++ code for addelkempn orthogonal array algorithm. - Fixed underlying C++ for bosebushl orthogonal array algorithm. - Added regression tests Changes in version 1.1.1 (2020-10-05) - Corrected memory leak and read out-of-bounds Changes in version 1.1.2 (2021-09-07) - Exposed functions related to Galois fields from the oa C++ library Changes in version 1.1.3 (2021-09-08) - Corrected compilation flag issue on Solaris Changes in version 1.1.4 (2022-02-20) - Correct error in logical statement with length > 1 Changes in version 1.1.5 (2022-03-22) - std::iterator, std::binary_function, and std::unary_funcation were removed since they are deprecated in c++17 and later lhs/R/0000755000176200001440000000000014115430532011237 5ustar liggesuserslhs/R/maximinLHS.R0000644000176200001440000001641714115501152013401 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{https://people.math.sc.edu/Burkardt/m_src/ihs/ihs.html} #' #' @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/get_library_versions.R0000644000176200001440000000062213754762734015641 0ustar liggesusers# Copyright 2020 Robert Carnell #' Get version information for all libraries in the lhs package #' #' @return a character string containing the versions #' @export #' #' @importFrom utils packageVersion #' #' @examples #' get_library_versions() get_library_versions <- function() { return(paste(.Call("get_library_versions", PACKAGE = "lhs"), "lhs:", utils::packageVersion("lhs"))) } lhs/R/galois_field.R0000644000176200001440000001074314115430532014010 0ustar liggesusers# Copyright 2021 Robert Carnell #' Create a Galois field #' #' @param q The order of the Galois Field q = p^n #' #' @return a GaloisField object containing #' \describe{ #' \item{n}{q = p^n} #' \item{p}{The prime modulus of the field q=p^n} #' \item{q}{The order of the Galois Field q = p^n. \code{q} must be a prime power.} #' \item{xton}{coefficients of the characteristic polynomial where the first coefficient is on $x^0$, the second is on $x^1$ and so on} #' \item{inv}{An index for which row of \code{poly} (zero based) is the multiplicative inverse of this row. An \code{NA} indicates that this row of \code{poly} has no inverse. e.g. c(3, 4) means that row 4=3+1 is the inverse of row 1 and row 5=4+1 is the inverse of row 2} #' \item{neg}{An index for which row of \code{poly} (zero based) is the negative or additive inverse of this row. An \code{NA} indicates that this row of \code{poly} has no negative. e.g. c(3, 4) means that row 4=3+1 is the negative of row 1 and row 5=4+1 is the negative of row 2} #' \item{root}{An index for which row of \code{poly} (zero based) is the square root of this row. An \code{NA} indicates that this row of \code{poly} has no square root. e.g. c(3, 4) means that row 4=3+1 is the square root of row 1 and row 5=4+1 is the square root of row 2} #' \item{plus}{sum table of the Galois Field} #' \item{times}{multiplication table of the Galois Field} #' \item{poly}{rows are polynomials of the Galois Field where the entries are the coefficients of the polynomial where the first coefficient is on $x^0$, the second is on $x^1$ and so on} #' } #' @export #' #' @examples #' gf <- create_galois_field(4); create_galois_field <- function(q) { if (q <= 1) stop("q must be 2 or greater") gf <- .Call("create_galois_field", as.integer(q), PACKAGE = "lhs") class(gf) <- "GaloisField" names(gf) <- c("n", "p", "q", "xton", "inv", "neg", "root", "plus", "times", "poly") if (any(gf$inv == -1)) gf$inv[which(gf$inv == -1)] <- NA if (any(gf$neg == -1)) gf$neg[which(gf$neg == -1)] <- NA if (any(gf$root == -1)) gf$root[which(gf$root == -1)] <- NA return(gf) } #' Multiplication in polynomial representation #' #' @param p modulus #' @param n length of polynomials #' @param xton characteristic polynomial vector for the field (x to the n power) #' @param p1 polynomial vector 1 #' @param p2 polynomial vector 2 #' #' @return the product of p1 and p2 #' @export #' #' @examples #' gf <- create_galois_field(4) #' a <- poly_prod(gf$p, gf$n, gf$xton, c(1, 0), c(0, 1)) #' stopifnot(all(a == c(0, 1))) poly_prod <- function(p, n, xton, p1, p2) { if (n != length(xton)) stop("the length of xton must be n") if (n != length(p1)) stop("the length of p1 must be n") if (n != length(p2)) stop("the length of p2 must be n") if (any(c(xton, p1, p2) >= p)) stop("The entries of the polynomial vectors must be less than p") if (any(c(xton, p1, p2) < 0)) stop("The entries of the polynomial vectors must be greater than 0") .Call("poly_prod", as.integer(p), as.integer(n), as.integer(xton), as.integer(p1), as.integer(p2), PACKAGE = "lhs") } #' Addition in polynomial representation #' #' @param p modulus #' @param n length of polynomial 1 and 2 #' @param p1 polynomial vector 1 #' @param p2 polynomial vector 2 #' #' @return the sum of p1 and p2 #' @export #' #' @examples #' gf <- create_galois_field(4) #' a <- poly_sum(gf$p, gf$n, c(1, 0), c(0, 1)) #' stopifnot(all(a == c(1, 1))) poly_sum <- function(p, n, p1, p2) { if (n != length(p1)) stop("the length of p1 must be n") if (n != length(p2)) stop("the length of p2 must be n") if (any(c(p1, p2) >= p)) stop("The entries of the polynomial vectors must be less than p") if (any(c(p1, p2) < 0)) stop("The entries of the polynomial vectors must be greater than 0") .Call("poly_sum", as.integer(p), as.integer(n), as.integer(p1), as.integer(p2), PACKAGE = "lhs") } #' Convert polynomial to integer in 0..q-1 #' #' @param p modulus #' @param n the length of poly #' @param poly the polynomial vector #' #' @return an integer #' @export #' #' @examples #' gf <- create_galois_field(4) #' stopifnot(poly2int(gf$p, gf$n, c(0, 0)) == 0) poly2int <- function(p, n, poly) { if (n != length(poly)) stop("the length of poly must be n") if (any(poly >= p)) stop("The entries of the polynomial vectors must be less than p") if (any(poly < 0)) stop("The entries of the polynomial vectors must be greater than 0") .Call("poly2int", as.integer(p), as.integer(n), as.integer(poly), PACKAGE = "lhs") } 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/improvedLHS.r0000644000176200001440000000601014115501127013612 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{https://people.math.sc.edu/Burkardt/m_src/ihs/ihs.html} #' #' @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/runifint.r0000644000176200001440000000100713636661136013273 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} #' #' @export #' @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/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/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/lhs.R0000644000176200001440000000015213416455041012153 0ustar liggesusers# Copyright 2019 Robert Carnell #' @useDynLib lhs #' @keywords internal #' @import Rcpp "_PACKAGE" lhs/R/createOA.R0000644000176200001440000003140213754762666013075 0ustar liggesusers# Copyright 2019 Robert Carnell #' Create an orthogonal array using the Bose algorithm. #' #' The \code{bose} program #' produces \code{OA( q^2, k, q, 2 )}, \code{k <= q+1} for prime powers \code{q}. #' #' From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} #' columns with every element being one of \code{q} symbols #' \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} #' submatrix, the \code{q^t} possible distinct rows, all appear #' the same number of times. This number is the index #' of the array, commonly denoted \code{lambda}. Clearly, #' \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. #' #' @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 #' @references #' Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 #' R.C. Bose (1938) Sankhya Vol 3 pp 323-338 #' @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. #' #' The \code{bosebush} program #' produces \code{OA( 2q^2, k, q, 2 )}, \code{k <= 2q+1}, for powers of 2, \code{q=2^r}. #' #' From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} #' columns with every element being one of \code{q} symbols #' \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} #' submatrix, the \code{q^t} possible distinct rows, all appear #' the same number of times. This number is the index #' of the array, commonly denoted \code{lambda}. Clearly, #' \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. #' #' @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 #' @references #' Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 #' R.C. Bose and K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 508-524. #' @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. #' #' The \code{bush} program #' produces \code{OA( q^3, k, q, 3 )}, \code{k <= q+1} for prime powers \code{q}. #' #' From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} #' columns with every element being one of \code{q} symbols #' \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} #' submatrix, the \code{q^t} possible distinct rows, all appear #' the same number of times. This number is the index #' of the array, commonly denoted \code{lambda}. Clearly, #' \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. #' #' @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 #' @references #' Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 #' K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 426-434 #' @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. #' #' The \code{addelkemp} program produces \code{OA( 2q^2, k, q, 2 )}, \code{k <= 2q+1}, #' for odd prime powers \code{q}. #' #' From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} #' columns with every element being one of \code{q} symbols #' \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} #' submatrix, the \code{q^t} possible distinct rows, all appear #' the same number of times. This number is the index #' of the array, commonly denoted \code{lambda}. Clearly, #' \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. #' #' @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 #' @references #' Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 #' S. Addelman and O. Kempthorne (1961) Annals of Mathematical Statistics, Vol 32 pp 1167-1176. #' @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 \code{2q^3} rows. #' #' The \code{addelkemp3} program produces #' \code{OA( 2*q^3, k, q, 2 )}, \code{k <= 2q^2+2q+1}, for prime powers \code{q}. #' \code{q} may be an odd prime power, or \code{q} may be 2 or 4. #' #' From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} #' columns with every element being one of \code{q} symbols #' \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} #' submatrix, the \code{q^t} possible distinct rows, all appear #' the same number of times. This number is the index #' of the array, commonly denoted \code{lambda}. Clearly, #' \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. #' #' @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 #' @references #' Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 #' S. Addelman and O. Kempthorne (1961) Annals of Mathematical Statistics, Vol 32 pp 1167-1176. #' @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. #' #' The \code{busht} program produces \code{OA( q^t, k, q, t )}, \code{k <= q+1}, \code{t>=3}, #' for prime powers \code{q}. #' #' From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} #' columns with every element being one of \code{q} symbols #' \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} #' submatrix, the \code{q^t} possible distinct rows, all appear #' the same number of times. This number is the index #' of the array, commonly denoted \code{lambda}. Clearly, #' \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. #' #' @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 #' @references #' Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 #' K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 426-434 #' @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. #' #' The \code{bosebushl} program produces \code{OA( lambda*q^2, k, q, 2 )}, #' \code{k <= lambda*q+1}, for prime powers \code{q} and \code{lambda > 1}. Both \code{q} and #' \code{lambda} must be powers of the same prime. #' #' From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} #' columns with every element being one of \code{q} symbols #' \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} #' submatrix, the \code{q^t} possible distinct rows, all appear #' the same number of times. This number is the index #' of the array, commonly denoted \code{lambda}. Clearly, #' \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. #' #' @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 #' @references #' Owen, Art. Orthogonal Arrays for: Computer Experiments, Visualizations, and Integration in high dimenstions. \url{http://lib.stat.cmu.edu/designs/oa.c}. 1994 #' R.C. Bose and K.A. Bush (1952) Annals of Mathematical Statistics, Vol 23 pp 508-524. #' @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 with \code{2q^n} rows. #' #' The \code{addelkempn} program produces #' \code{OA( 2*q^n, k, q, 2 )}, \code{k <= 2(q^n - 1)/(q-1)-1}, for prime powers \code{q}. #' \code{q} may be an odd prime power, or \code{q} may be 2 or 4. #' #' From Owen: An orthogonal array \code{A} is a matrix of \code{n} rows, \code{k} #' columns with every element being one of \code{q} symbols #' \code{0,...,q-1}. The array has strength \code{t} if, in every \code{n} by \code{t} #' submatrix, the \code{q^t} possible distinct rows, all appear #' the same number of times. This number is the index #' of the array, commonly denoted \code{lambda}. Clearly, #' \code{lambda*q^t=n}. The notation for such an array is \code{OA( n, k, q, t )}. #' #' @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/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/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/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/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/MD50000644000176200001440000001503714347432332011363 0ustar liggesusersf85d7ad91e5678df6269ab3fe3cd2fb5 *ChangeLog 2834f77c3ef7e7c7923b45caf9ff0b03 *DESCRIPTION 4ad42b6ea879a1ef4e8ca522e4ada103 *NAMESPACE 7682a7a4a5bf002eba4e023c8e1424fb *NEWS 53866b3921acf88d621f1b67d6bf5517 *R/augmentLHS.R 851e4e4b32ef0d1ff208e28d2469abfe *R/createOA.R e0aa8aefc35430288bf424573158dcfb *R/create_oalhs.R b13a12e4abeb22949dee39121869939d *R/galois_field.R ee054a9159cb67016025e58156c55044 *R/geneticLHS.R 82ff862f9d061d2f46603f15b34ef69c *R/get_library_versions.R 95a9a84bc9dbbef05bef322257008d78 *R/improvedLHS.r b9c800f8a568155f058dbf1f23732533 *R/lhs.R fdb66b50d5d88b352e6989aa64d8d830 *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 6f6a5d5f3f2e20c0fe869bfe603e0185 *R/runifint.r 56e6490634dd13cf2c388695e4de3878 *build/vignette.rds c40fe474107a72a524c98cd5d077c125 *inst/doc/augment_lhs.R 2ea4584a4f8f5710e9e845e365d054ea *inst/doc/augment_lhs.Rmd ac08a4276cafdafb5268dab36cdb007b *inst/doc/augment_lhs.html c3dd307ccf782db9eb75f1404cf37fa1 *inst/doc/lhs_basics.R c48d7934b6c01da2179998d83c78ac05 *inst/doc/lhs_basics.Rmd c97e76e9d3071d61d708f1442572b78e *inst/doc/lhs_basics.html 21ae80800268e1193314907b21c47fd5 *inst/doc/lhs_faq.R a098b867dd78ec2eb6963c40d7ba98ae *inst/doc/lhs_faq.Rmd e4b9622aade7a84fc154c19b5c01f3f1 *inst/doc/lhs_faq.html 385a89b5cd29ef880745c295821f72fa *man/augmentLHS.Rd d10b89e1edef0cdb6573410491331111 *man/createAddelKemp.Rd d93652e2d6e052941cef8e5570b5c9bf *man/createAddelKemp3.Rd 9c64475ba6ca348a2c5f8c36822a366b *man/createAddelKempN.Rd ed72fa68c7d3e584fa2b80fa71d85bc0 *man/createBose.Rd 6e32bddc752e147cecb5f6a47db72fae *man/createBoseBush.Rd 4e272403221932985d0aac3e2521b617 *man/createBoseBushl.Rd 15dc9afb06907b23657f3eebdb4fd567 *man/createBush.Rd 83f303068e111a84a1ecdf1576a2991a *man/createBusht.Rd 38387d12556c313404d634691e62dbd8 *man/create_galois_field.Rd 6099e0cdab76518961760e5b7ba376bb *man/create_oalhs.Rd d6530dd864441ec8150f21105202585f *man/geneticLHS.Rd cd434d0087818e7a7181d53b24d60280 *man/get_library_versions.Rd 4f9df18a7f626c11a539d4d7f4c86318 *man/improvedLHS.Rd 8d4d7796995d4ea88ef685b62c1eb733 *man/lhs-package.Rd 3cd0d73f8afe276b3a87095de0a4d2a2 *man/maximinLHS.Rd 602d1ee855b5e630920fb4f2c986ba33 *man/oa_to_oalhs.Rd 66532d58bedf1bb20bb8d3438b467266 *man/optAugmentLHS.Rd 5627fd6f80109463dea8108ad4973f1d *man/optSeededLHS.Rd 7fa0b5b23335f15cff50eebe4a2a8734 *man/optimumLHS.Rd 647d3e752fefe10507ee4451b00bea62 *man/poly2int.Rd 821b9245eb2944e0804502895ef4ca62 *man/poly_prod.Rd 61ee05edb765e3ab2cb4e01583300f4c *man/poly_sum.Rd a159b822a2135b86a0f29ab62fbb8a74 *man/randomLHS.Rd 17181180f6a19291e342196042bf6e3f *man/runifint.Rd f649001939ea771545339996d0bf614f *src/COrthogonalArray.cpp 62ba6f3afa35e087b202baf35923fee1 *src/COrthogonalArray.h 0cc862de831d9d7cfc565914f131cd9b *src/CRandom.h 66ad54cb00e04bda7bd043c888fb8094 *src/GaloisField.cpp 92dc5772d370e69822ec1db2035eb6cc *src/GaloisField.h 37769f1ff1637a4cb937ae9720561c2c *src/LHSCommonDefines.h f638d0697d0c1eb3fe1afedfdd157c15 *src/Makevars f3268dbce99fd476879b3695151fbb72 *src/Makevars.win b7e05dd7cf58418b0be2c70f8412c233 *src/OACommonDefines.h dd1ee7c05925ea002a3177907d472373 *src/RStandardUniform.h 72cfdd82c1f1edd241169ad8404557f9 *src/ak.h 364d8874ce60d9cc5f9522c56592aa3d *src/ak3.cpp bd451bd4e8a6367a9e662af3178fd088 *src/akconst.cpp 5e4afc32f8f25cf205344f18f24e0db4 *src/akn.cpp cd71d31647eff2e5a4031944d75689ea *src/bclibVersion.h c5fe11e7e9d4c35a354f00fc5573b8ab *src/construct.cpp e691f6ca99931970d3b5eea9afc416ce *src/construct.h 1692f74c2f90138327bb8904172cf751 *src/geneticLHS.cpp e2914a2b526a8c80a31843df76188edb *src/improvedLHS.cpp bc1767818bc7144993f2e0909087de44 *src/init.c 3e5fe0bbb790b6339dbfa15267eb22ae *src/lhs_r.cpp 24028cfc13b59c29abf5aeab955977b7 *src/lhs_r.h 112f5c99cef0996cfca96bdeea2fe88f *src/lhs_r_utilities.cpp 79e9b90afac77b5e3bdcf9c51c590c17 *src/lhs_r_utilities.h 98217866c6cb0fbc84feaeb59ae08413 *src/lhslibVersion.h 0d2df277fe0f51f1ce2980560d73c27e *src/matrix.h 72fe2357d4540e4d80aa662fd2f0981b *src/maximinLHS.cpp c67aea4118cb38c26d0e511be2f4fff5 *src/oa.cpp 9186645f453a8590983abe4ce5212b51 *src/oa.h e8093b9f81b7d27e75a57848e447d9f2 *src/oaLHS.cpp 45784fc7ab4837578bab9e1f79996fa1 *src/oaLHS.h 48c4f02615675fb58426db9187f9c968 *src/oaLHSUtility.h 1dcc1997f84c0f74b09d4b05f506877e *src/oa_r.cpp d3159e8a39d74eb007a44b8033dd3e3b *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 9454c11d37e62069bed7539ff7acdd69 *src/oalibVersion.h edbce6a4953d22430c00f5c163af41b2 *src/optSeededLHS.cpp 71acbe84d04803e29e466eba3dbd976e *src/optimumLHS.cpp 0537b1d2d2a33374e68331c1d4580fe7 *src/order.h 87c5d2c644299dcf7797cbf412fb3421 *src/primes.cpp 3cbd87dbf024f0f2ba7bb9651ffbc424 *src/primes.h 2d00c5e4034621e2afffa47ccb044e08 *src/randomLHS.cpp c86aac55d6f5d4e87f915d2c072ca915 *src/runif.cpp 2b9f7d7f9861e9fb2400963901bdf7b5 *src/runif.h 2a58c2e95481fe9f2d175db2bfc37947 *src/rutils.cpp bea92a5cc44b9602eedc5755adcb5e98 *src/rutils.h afc1a761a5f5bb4b5db9ab34916ab507 *src/utilityLHS.cpp 4e63bafed4e840585c42c6d4bb49379e *src/utilityLHS.h a9bf6acf833600dc23ea431f7cb8e97e *src/xtn.h 61a8d6137ec622105090092597f674f1 *tests/testthat.R fd5d335eac06aec0e329285f5078006e *tests/testthat/helper-lhs.R 2c7d56d1b00eda9f385a6ed433dcdc24 *tests/testthat/test-augmentlhs.R fe803b4ea05122c1f33700d69f4a4f42 *tests/testthat/test-create_oalhs.R a5464d4c7547b57abc92effb9b759a87 *tests/testthat/test-createoa.R 1d3eeffbf5f5fcb720a7bf51e7151e62 *tests/testthat/test-galois_field.R 15105804ea6ef87a0d84eea60d8f94fd *tests/testthat/test-geneticlhs.R 5f5f6cae1a495855aefb68f51a254be2 *tests/testthat/test-get_library_versions.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 1dfdaa44c78fdaca863983c32b1d804a *tests/testthat/test-randomlhs.r 8f248fe4625ca971df2ab8b8f503fc6d *vignettes/VignetteCommonCode.R 2ea4584a4f8f5710e9e845e365d054ea *vignettes/augment_lhs.Rmd c48d7934b6c01da2179998d83c78ac05 *vignettes/lhs_basics.Rmd a098b867dd78ec2eb6963c40d7ba98ae *vignettes/lhs_faq.Rmd lhs/inst/0000755000176200001440000000000014347415522012024 5ustar liggesuserslhs/inst/doc/0000755000176200001440000000000014347415522012571 5ustar liggesuserslhs/inst/doc/lhs_basics.R0000644000176200001440000001201214347415516015025 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_basics.html0000644000176200001440000030043414347415516015600 0ustar liggesusers Basic Latin hypercube samples and designs with package lhs

Basic Latin hypercube samples and designs with package lhs

Rob Carnell

2022-12-17

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")
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 5. Pairwise margins of a maximinLHS

lhs/inst/doc/lhs_faq.html0000644000176200001440000042127614347415522015110 0ustar liggesusers Latin Hypercube Samples - Questions

Latin Hypercube Samples - Questions

Rob Carnell

2022-12-17

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, 10) 
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,] 6.479409 24.56478
#> [2,] 3.773547 24.42880
#> [3,] 2.810315 27.42119
#> [4,] 5.133860 28.56320
#> [5,] 3.902311 25.25066
#> [6,] 9.530130 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,]    2   36
#> [2,]    5   40
#> [3,]    7   33
#> [4,]    3   31
#> [5,]   10   38
integerLHS(2, list(1:10, 31:40)) 
#>      [,1] [,2]
#> [1,]    5   34
#> [2,]    6   37
integerLHS(5, list(1:20, 31:60, 101:115)) 
#>      [,1] [,2] [,3]
#> [1,]   17   59  110
#> [2,]   12   34  102
#> [3,]    5   46  108
#> [4,]   16   39  106
#> [5,]    2   52  115
integerLHS(5, list(seq(2,20,2), 31:60, 101:115)) 
#>      [,1] [,2] [,3]
#> [1,]    4   57  101
#> [2,]   14   34  104
#> [3,]    8   48  115
#> [4,]   10   53  109
#> [5,]   20   41  112

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.933889e-06 8.593339e-01

ws <- randomLHS(1000, 7) 
wsSums <- rowSums(ws) 
wss <- ws / wsSums 
stopifnot(all(abs(rowSums(wss) - 1) < 1E-12)) 
range(wss)
#> [1] 2.172278e-05 5.239118e-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/augment_lhs.R0000644000176200001440000000433314347415513015225 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/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/augment_lhs.html0000644000176200001440000010406514347415514015774 0ustar liggesusers An Example of Augmenting a Latin Hypercube

An Example of Augmenting a Latin Hypercube

Rob Carnell

2022-12-17

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.

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.

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 Figure 3 and Figure 4. The commands were:

A <- randomLHS(7, 2)
B <- augmentLHS(A, 3)
Figure 4. Augmented design with 3 additional points. Note that row 9 has 2 points and row 3 has none.

lhs/inst/doc/lhs_faq.Rmd0000644000176200001440000002322613636661764014672 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, 10) 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.Rmd0000644000176200001440000001717014204306507015347 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/lhs_faq.R0000644000176200001440000001520614347415521014334 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, 10) 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,]