Added test for NAs in omxCheckCloseEnough()
[openmx:openmx.git] / R / MxUnitTesting.R
1 #
2 #   Copyright 2007-2009 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 omxCheckEquals <- function(a, b) {
58         checkEqualDimensions(a, b)      
59         if (any(a != b)) {
60                 stop(paste(a, "and", b, "are not equal"))
61         } else if (getOption("mxPrintUnitTests")) {
62                 cat(paste(deparse(match.call()$a), "and", 
63                         deparse(match.call()$b),
64                         "are equal.\n"))        
65         }
66 }
67
68 omxCheckSetEquals <- function(a, b) {
69         checkEqualDimensions(a, b)      
70         if (!setequal(a, b)) {
71                 stop(paste(a, "and", b, "do not contain the same elements"))
72         } else if (getOption("mxPrintUnitTests")) {
73                 cat(paste(deparse(match.call()$a), "and", 
74                         deparse(match.call()$b),
75                         "contain the same elements.\n"))
76         }
77 }
78
79 omxCheckTrue <- function(a) {   
80         if (any(!a)) {
81                 stop(paste(match.call()$a, "is not true"))
82         } else if (getOption("mxPrintUnitTests")) {
83                 cat(paste(deparse(match.call()$a), 
84                         "is true.", '\n'))
85         }
86 }
87
88
89 omxCheckCloseEnough <- function(a, b, epsilon=10^(-15)) {
90         checkEqualDimensions(a, b)
91         if(any(mapply(function(x,y) {
92                         is.na(a) || is.na(b) },
93                         as.vector(a), as.vector(b)))) {
94                 stop("omxCheckCloseEnough does not support NA values")
95         }
96         check <- any(mapply(function(x,y) {
97                         abs(x - y) > epsilon }, 
98                         as.vector(a), as.vector(b)))
99         if (check) {
100                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
101                         "and", omxQuotes(paste(b, collapse = ' ')), 
102                         "are not equal to within", epsilon))
103         } else if (getOption("mxPrintUnitTests")) {
104                 cat(paste(deparse(match.call()$a), "and", 
105                         deparse(match.call()$b),
106                         "are equal to within", paste(epsilon, ".\n", sep = '')))
107         }
108 }
109
110 omxCheckWithinPercentError <- function(a, b, epsilon=10^(-15)) {
111         checkEqualDimensions(a, b)      
112         check <- any(mapply(function(x,y) {
113                         (abs(x - y)/x * 100) > epsilon }, 
114                         as.vector(a), as.vector(b)))    
115         if (check) {
116                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
117                         "does not estimate", 
118                         omxQuotes(paste(b, collapse = ' ')), 
119                         "within", epsilon, "percent"))
120         } else if (getOption("mxPrintUnitTests")) {
121                 cat(paste(deparse(match.call()$a), "and", 
122                         deparse(match.call()$b),
123                         "are equal to within", epsilon, "percent.\n"))
124         }
125 }