Make omxCheckCloseEnough compare missingness pattern too
[openmx:openmx.git] / R / MxUnitTesting.R
1 #
2 #   Copyright 2007-2012 The OpenMx Project
3 #
4 #   Licensed under the Apache License, Version 2.0 (the "License");
5 #   you may not use this file except in compliance with the License.
6 #   You may obtain a copy of the License at
7
8 #        http://www.apache.org/licenses/LICENSE-2.0
9
10 #   Unless required by applicable law or agreed to in writing, software
11 #   distributed under the License is distributed on an "AS IS" BASIS,
12 #   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 #   See the License for the specific language governing permissions and
14 #   limitations under the License.
15
16
17 checkZeroDimensions <- function(a, b) {
18         if ((length(a) == 0 && length(b) > 0) ||
19                 (length(a) > 0 && length(b) == 0)) {
20                         stop(paste("One of these has zero length:",
21                                 omxQuotes(paste(a, collapse = ' ')), 
22                                 "and", omxQuotes(paste(b, collapse = ' '))))    
23         } else if (length(a) == 0 && length(b) == 0) {
24                 warning("Both values have zero length.  That's weird.")
25         }
26 }
27
28 checkEqualDimensions <- function(a, b) {
29         checkZeroDimensions(a, b)
30         if((is.vector(a) && length(a) > 1 && !is.vector(b)) || 
31                 (is.vector(b) && length(b) > 1 && !is.vector(a))) {
32                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
33                         "and", omxQuotes(paste(b, collapse = ' ')), 
34                         "are not both vectors"))        
35         }
36         if((is.matrix(a) && (nrow(a) > 1 || ncol(a) > 1) && !is.matrix(b)) || 
37                 (is.matrix(b) && (nrow(b) > 1 || ncol(b) > 1) && !is.matrix(a))) {
38                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
39                         "and", omxQuotes(paste(b, collapse = ' ')), 
40                         "are not both matrices"))       
41         }       
42         if (is.vector(a) && (length(a) != length(b))) {
43                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
44                         "and", omxQuotes(paste(b, collapse = ' ')), 
45                         "do not have equal length :",
46                         length(a), 'and', length(b)))
47         }
48         if (is.matrix(a) && (nrow(a) > 1 || ncol(a) > 1) && any(dim(a) != dim(b))) {
49                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
50                         "and", omxQuotes(paste(b, collapse = ' ')), 
51                         "are not of equal dimension :", 
52                         paste(dim(a), collapse = ' x '), 'and', 
53                         paste(dim(b), collapse = ' x ')))
54         }
55 }
56
57 omxCheckIdentical <- function(a, b) {
58         checkEqualDimensions(a, b)      
59         if (any(!identical(a, b))) {
60                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
61                         "and", omxQuotes(paste(b, collapse = ' ')), 
62                         "are not identical"))
63         } else if (getOption("mxPrintUnitTests")) {
64                 cat(paste(deparse(match.call()$a), "and", 
65                         deparse(match.call()$b),
66                         "are identical.\n"))    
67         }
68 }
69
70 omxCheckEquals <- function(a, b) {
71         checkEqualDimensions(a, b)      
72         if (any(a != b)) {
73                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
74                         "and", omxQuotes(paste(b, collapse = ' ')), 
75                         "are not equal"))
76         } else if (getOption("mxPrintUnitTests")) {
77                 cat(paste(deparse(match.call()$a), "and", 
78                         deparse(match.call()$b),
79                         "are equal.\n"))        
80         }
81 }
82
83 omxCheckSetEquals <- function(a, b) {
84         if (!setequal(a, b)) {
85                 stop(paste(omxQuotes(paste(b, collapse = ' ')), 
86                         "and", omxQuotes(paste(b, collapse = ' ')), 
87                         "do not contain the same elements"))
88         } else if (getOption("mxPrintUnitTests")) {
89                 cat(paste(deparse(match.call()$a), "and", 
90                         deparse(match.call()$b),
91                         "contain the same elements.\n"))
92         }
93 }
94
95 omxCheckTrue <- function(a) {   
96         if (any(!a)) {
97                 call <- deparse(match.call()$a)
98                 stop(paste(call, "is not true"))
99         } else if (getOption("mxPrintUnitTests")) {
100                 call <- deparse(match.call()$a)
101                 cat(paste(call, "is true.", '\n'))
102         }
103 }
104
105 ##' Approximate Equality Testing Function
106 ##'
107 ##' This function tests whether two numeric vectors or matrixes are
108 ##' approximately equal to one another, within a specified threshold.
109 ##'
110 ##' Arguments \sQuote{a} and \sQuote{b} must be of the same type,
111 ##' ie. they must be either vectors of equal dimension or matrices of
112 ##' equal dimension. The two arguments are compared element-wise for
113 ##' approximate equality.  If the absolute value of the difference of
114 ##' any two values is greater than the threshold, then an error will
115 ##' be thrown. If \sQuote{a} and \sQuote{b} are approximately equal to
116 ##' each other, by default the function will print a statement
117 ##' informing the user the test has passed.  To turn off these print
118 ##' statements use \code{options("mxPrintUnitTests" = FALSE)}.
119 ##'
120 ##' When na.action is set to na.pass, a and b are expected to have
121 ##' identical missingness patterns.
122 ##'
123 ##' @param a a numeric vector or matrix
124 ##' @param b a numeric vector or matrix
125 ##' @param epsilon a non-negative tolerance threshold
126 ##' @param na.action either na.fail (default) or na.pass. Use of
127 ##' na.omit or na.exclude is not recommended.
128 ##' @seealso
129 ##' \code{\link{omxCheckWithinPercentError}},
130 ##' \code{\link{omxCheckIdentical}}, \code{\link{omxCheckSetEquals}},
131 ##' \code{\link{omxCheckTrue}}, \code{\link{omxCheckEquals}}
132 ##' @references
133 ##' The OpenMx User's guide can be found at http://openmx.psyc.virginia.edu/documentation.
134 ##' @examples
135 ##' omxCheckCloseEnough(c(1, 2, 3), c(1.1, 1.9 ,3.0), epsilon = 0.5)
136 ##' omxCheckCloseEnough(matrix(3, 3, 3), matrix(4, 3, 3), epsilon = 2)
137 ##' # Throws an error
138 ##' try(omxCheckCloseEnough(c(1, 2, 3), c(1.1, 1.9 ,3.0), epsilon = 0.01))
139 omxCheckCloseEnough <- function(a, b, epsilon = 10^(-15), na.action=na.fail) {
140         if (epsilon < 0) stop("epsilon must be non-negative")
141         checkEqualDimensions(a, b)
142         a <- na.action(a)
143         b <- na.action(b)
144         if (any(is.na(a) != is.na(b))) {
145                 stop(paste("In", deparse(width.cutoff = 400L, sys.call()), ":",
146                         omxQuotes(paste(a, collapse = ' ')),
147                         "and", omxQuotes(paste(b, collapse = ' ')),
148                         "have different missingness patterns"),
149                         call. = FALSE)
150         }
151         a.vec <- as.vector(a)
152         b.vec <- as.vector(b)
153         a.vec <- a.vec[!is.na(a.vec)]
154         b.vec <- b.vec[!is.na(b.vec)]
155         check <- any(mapply(function(x,y) {
156                         abs(x - y) > epsilon }, 
157                         a.vec, b.vec))
158         if (check) {
159                 stop(paste("In", deparse(width.cutoff = 400L, sys.call()), ":",
160                         omxQuotes(paste(a, collapse = ' ')), 
161                         "and", omxQuotes(paste(b, collapse = ' ')), 
162                         "are not equal to within", epsilon), 
163                         call. = FALSE)
164         } else if (getOption("mxPrintUnitTests")) {
165                 cat(paste(deparse(match.call()$a), "and", 
166                         deparse(match.call()$b),
167                         "are equal to within", paste(epsilon, ".\n", sep = '')))
168         }
169 }
170
171 omxCheckWithinPercentError <- function(a, b, percent = 0.1) {
172         checkEqualDimensions(a, b)      
173         check <- any(mapply(function(x,y) {
174                         (abs(x - y)/x * 100) > percent }, 
175                         as.vector(a), as.vector(b)))    
176         if (check) {
177                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
178                         "does not estimate", 
179                         omxQuotes(paste(b, collapse = ' ')), 
180                         "within", percent, "percent"))
181         } else if (getOption("mxPrintUnitTests")) {
182                 cat(paste(deparse(match.call()$a), "and", 
183                         deparse(match.call()$b),
184                         "are equal to within", percent, "percent.\n"))
185         }
186 }
187
188 trim <- function(input) {
189         input <- sub("(?m)^\\s+", "", input, perl = TRUE)
190         input <- sub("(?m)\\s+$", "", input, perl = TRUE)
191         return(input)
192 }
193
194 omxCheckWarning <- function(expression, message) {
195         inputExpression <- match.call()$expression
196         checkWarningState <- FALSE
197         tryCatch(eval(inputExpression), warning = function(x) {
198                 if(trim(x$message) != trim(message)) {
199                         stop(paste("An warning was thrown with the wrong message:",
200                                 x$message), call. = FALSE)
201                 } else { checkWarningState <<- TRUE }
202         })
203         if (!checkWarningState) {
204                 stop(paste("No warning was observed for the expression",
205                         deparse(inputExpression, width.cutoff = 500L)), call. = FALSE)
206         } else if (getOption("mxPrintUnitTests")) {
207                 cat(paste("The expected warning was observed for the expression",
208                         deparse(inputExpression, width.cutoff = 500L), '\n'))
209         }
210 }
211
212 omxCheckError <- function(expression, message) {
213         inputExpression <- match.call()$expression
214         checkErrorState <- FALSE
215         tryCatch(eval(inputExpression), error = function(x) {
216                 if(trim(x$message) != trim(message)) {
217                         stop(paste("An error was thrown with the wrong message:",
218                                 x$message), call. = FALSE)
219                 } else { checkErrorState <<- TRUE }
220         })
221         if (!checkErrorState) {
222                 stop(paste("No error was observed for the expression",
223                         deparse(inputExpression, width.cutoff = 500L)), call. = FALSE)
224         } else if (getOption("mxPrintUnitTests")) {
225                 cat(paste("The expected error was observed for the expression",
226                         deparse(inputExpression, width.cutoff = 500L), '\n'))
227         }
228 }