Finishing to set eol-style native on these R files.
[openmx:openmx.git] / R / MxUnitTesting.R
1 #
2 #   Copyright 2007-2010 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                 stop(paste(match.call()$a, "is not true"))
98         } else if (getOption("mxPrintUnitTests")) {
99                 cat(paste(deparse(match.call()$a), 
100                         "is true.", '\n'))
101         }
102 }
103
104
105 omxCheckCloseEnough <- function(a, b, epsilon = 10^(-15)) {
106         checkEqualDimensions(a, b)
107         if(any(mapply(function(x,y) {
108                         is.na(a) || is.na(b) },
109                         as.vector(a), as.vector(b)))) {
110                 stop("omxCheckCloseEnough does not support NA values")
111         }
112         check <- any(mapply(function(x,y) {
113                         abs(x - y) > epsilon }, 
114                         as.vector(a), as.vector(b)))
115         if (check) {
116                 stop(paste("In", deparse(width.cutoff = 400L, sys.call()), ":",
117                         omxQuotes(paste(a, collapse = ' ')), 
118                         "and", omxQuotes(paste(b, collapse = ' ')), 
119                         "are not equal to within", epsilon), 
120                         call. = FALSE)
121         } else if (getOption("mxPrintUnitTests")) {
122                 cat(paste(deparse(match.call()$a), "and", 
123                         deparse(match.call()$b),
124                         "are equal to within", paste(epsilon, ".\n", sep = '')))
125         }
126 }
127
128 omxCheckWithinPercentError <- function(a, b, percent = 0.1) {
129         checkEqualDimensions(a, b)      
130         check <- any(mapply(function(x,y) {
131                         (abs(x - y)/x * 100) > percent }, 
132                         as.vector(a), as.vector(b)))    
133         if (check) {
134                 stop(paste(omxQuotes(paste(a, collapse = ' ')), 
135                         "does not estimate", 
136                         omxQuotes(paste(b, collapse = ' ')), 
137                         "within", percent, "percent"))
138         } else if (getOption("mxPrintUnitTests")) {
139                 cat(paste(deparse(match.call()$a), "and", 
140                         deparse(match.call()$b),
141                         "are equal to within", percent, "percent.\n"))
142         }
143 }
144
145 trim <- function(input) {
146         input <- sub("(?m)^\\s+", "", input, perl = TRUE)
147         input <- sub("(?m)\\s+$", "", input, perl = TRUE)
148         return(input)
149 }
150
151 omxCheckError <- function(expression, message) {
152         inputExpression <- match.call()$expression
153         checkErrorState <- FALSE
154         tryCatch(eval(inputExpression), error = function(x) {
155                 if(trim(x$message) != trim(message)) {
156                         stop(paste("An error was thrown with the wrong message:",
157                                 x$message), call. = FALSE)
158                 } else { checkErrorState <<- TRUE }
159         })
160         if (!checkErrorState) {
161                 stop(paste("No error was observed for the expression",
162                         deparse(inputExpression, width.cutoff = 500L)), call. = FALSE)
163         } else if (getOption("mxPrintUnitTests")) {
164                 cat(paste("The expected error was observed for the expression",
165                         deparse(inputExpression, width.cutoff = 500L), '\n'))
166         }
167 }