1## amcheck.r 2## Function for checking for errors in coding 3## of the data or input vectors 4## 5## 21/10/05 - now converts variables names to column numbers, stops if variable doesn't exist; returns codes and messages, doesn't stop execution 6## 04/05/06 mb - moved parameter vs. obs check to prep, checks outname 7## 10/07/06 mb - fixed handling of variance checks with no fully observed rows. 8## 17/07/06 mb - stops if variable only has one observed value. 9## 02/08/06 mb - fixed handling of character variables. 10## 25/09/06 mb - fixed handling of errors in output writing. 11## 13/12/06 mb - removed dropping of extra priors, added new priors 12## 15/12/06 mb - fixed problem of nrow(priors)==5 13## 22/07/08 mb - good coding update: T->TRUE/F->FALSE 14## 27/03/10 jh - added checks for splinetime 15 16 17 18amcheck <- function(x,m=5,p2s=1,frontend=FALSE,idvars=NULL,logs=NULL, 19 ts=NULL,cs=NULL,means=NULL,sds=NULL, 20 mins=NULL,maxs=NULL,conf=NULL,empri=NULL, 21 tolerance=0.0001,polytime=NULL,splinetime=NULL,startvals=0,lags=NULL, 22 leads=NULL,intercs=FALSE,archive=TRUE,sqrts=NULL, 23 lgstc=NULL,noms=NULL,incheck=TRUE,ords=NULL,collect=FALSE, 24 arglist=NULL, priors=NULL,bounds=NULL, 25 max.resample=1000, overimp = NULL, emburn=NULL, boot.type=NULL) { 26 27 #Checks for errors in list variables 28 listcheck<-function(vars,optname) { 29 if (identical(vars,NULL)) 30 return(0) 31 if (mode(vars) == "character") { 32 if (any(is.na(match(vars,colnames(x))))) { 33 mess<-paste("The following variables are refered to in the", 34 optname,"argument, but don't are not columns in the data:", 35 vars[is.na(match(vars,colnames(x)))]) 36 return(list(1,mess)) 37 } 38 return(0) 39 } 40 if (any(vars>AMp,vars<0,vars%%1!=0)) { 41 mess<-paste(optname," is out of the range of \n", 42 "possible column numbers or is not an integer.") 43 return(list(2,mess)) 44 } 45 return(0) 46 } 47 48 #Checks for errors in logical variables 49 logiccheck<-function(opt,optname) { 50 if (!identical(opt,NULL)) { 51 if (length(opt) > 1) { 52 mess<-paste("The",optname,"setting is longer than one logical.") 53 return(list(1,mess)) 54 } 55 if (mode(opt) != "logical") { 56 mess<-paste("The",optname,"setting is not a logical (TRUE/FALSE) value.") 57 return(list(2,mess)) 58 } 59 } else { 60 mess<-paste("The",optname,"setting cannot be NULL. Please change to TRUE/FALSE.") 61 return(list(3,mess)) 62 } 63 return(0) 64 } 65 66 #Checks for errors in priors variables 67 priorcheck<-function(opt,optname) { 68 if (!identical(opt,NULL)) { 69 if (!is.matrix(opt)) { 70 mess<-paste("The", optname,"matrix is not a matrix.\n") 71 return(list(1,mess)) 72 } 73 if (is.character(opt)) { 74 mess<-paste("The", optname,"matrix is a character matrix.\n", 75 "Please change it to a numeric matrix.") 76 return(list(2,mess)) 77 } 78 if (any(dim(opt)!=dim(x))) { 79 mess<-paste("The", optname,"matrices must have the same dimensions\n", 80 "as the data.") 81 return(list(3,mess)) 82 } 83 } 84 return(0) 85 } 86 87 error.code <- 1 88 89 90 91 92 #Error Code: 3 93 #Arguments point to variables that do not exist. 94 if (inherits(try(get("x"),silent=TRUE),"try-error")) 95 return(list(code=3,mess=paste("The setting for the data argument doesn't exist."))) 96 if (inherits(try(get("m"),silent=TRUE),"try-error")) 97 return(list(code=3,mess=paste("The setting for the 'm' argument doesn't exist."))) 98 99 if (inherits(try(get("idvars"),silent=TRUE),"try-error")) 100 return(list(code=3,mess=paste("The setting for the 'idvars' argument doesn't exist."))) 101 102 if (inherits(try(get("means"),silent=TRUE),"try-error")) 103 return(list(code=3,mess=paste("The setting for the 'means' argument doesn't exist."))) 104 105 if (inherits(try(get("sds"),silent=TRUE),"try-error")) 106 return(list(code=3,mess=paste("The setting for the 'sds' argument doesn't exist."))) 107 108 if (inherits(try(get("mins"),silent=TRUE),"try-error")) 109 return(list(code=3,mess=paste("The setting for the 'mins' argument doesn't exist."))) 110 111 if (inherits(try(get("maxs"),silent=TRUE),"try-error")) 112 return(list(code=3,mess=paste("The setting for the 'maxs' argument doesn't exist."))) 113 114 if (inherits(try(get("conf"),silent=TRUE),"try-error")) 115 return(list(code=3,mess=paste("The setting for the 'conf' argument doesn't exist."))) 116 117 if (inherits(try(get("empri"),silent=TRUE),"try-error")) 118 return(list(code=3,mess=paste("The setting for the 'empri' argument doesn't exist."))) 119 120 if (inherits(try(get("ts"),silent=TRUE),"try-error")) 121 return(list(code=3,mess=paste("The setting for the 'ts' argument doesn't exist."))) 122 123 if (inherits(try(get("cs"),silent=TRUE),"try-error")) 124 return(list(code=3,mess=paste("The setting for the 'cs' argument doesn't exist."))) 125 126 if (inherits(try(get("tolerance"),silent=TRUE),"try-error")) 127 return(list(code=3,mess=paste("The setting for the 'tolerance' argument doesn't exist."))) 128 129 if (inherits(try(get("polytime"),silent=TRUE),"try-error")) 130 return(list(code=3,mess=paste("The setting for the 'polytime' argument doesn't exist."))) 131 132 if (inherits(try(get("splinetime"),silent=TRUE),"try-error")) 133 return(list(code=3,mess=paste("The setting for the 'splinetime' argument doesn't exist."))) 134 135 if (inherits(try(get("lags"),silent=TRUE),"try-error")) 136 return(list(code=3,mess=paste("The setting for the 'lags' argument doesn't exist."))) 137 138 if (inherits(try(get("leads"),silent=TRUE),"try-error") ) 139 return(list(code=3,mess=paste("The setting for the 'leads' argument doesn't exist."))) 140 141 if (inherits(try(get("logs"),silent=TRUE),"try-error")) 142 return(list(code=3,mess=paste("The setting for the 'logs' argument doesn't exist."))) 143 144 if (inherits(try(get("sqrts"),silent=TRUE),"try-error")) 145 return(list(code=3,mess=paste("The setting for the 'sqrts' argument doesn't exist."))) 146 147 if (inherits(try(get("lgstc"),silent=TRUE),"try-error")) 148 return(list(code=3,mess=paste("The setting for the 'lgstc' argument doesn't exist."))) 149 150 if (inherits(try(get("p2s"),silent=TRUE),"try-error")) 151 return(list(code=3,mess=paste("The setting for the 'p2s' argument doesn't exist."))) 152 153 if (inherits(try(get("frontend"),silent=TRUE),"try-error")) 154 return(list(code=3,mess=paste("The setting for the 'frontend' argument doesn't exist."))) 155 156 if (inherits(try(get("intercs"),silent=TRUE),"try-error")) 157 return(list(code=3,mess=paste("The setting for the 'intercs' argument doesn't exist."))) 158 159 if (inherits(try(get("noms"),silent=TRUE),"try-error")) 160 return(list(code=3,mess=paste("The setting for the 'noms' argument doesn't exist."))) 161 162 if (inherits(try(get("startvals"),silent=TRUE),"try-error")) 163 return(list(code=3,mess=paste("The setting for the 'startvals' argument doesn't exist."))) 164 165 if (inherits(try(get("ords"),silent=TRUE),"try-error")) 166 return(list(code=3,mess=paste("The setting for the 'ords' argument doesn't exist."))) 167 168 if (inherits(try(get("collect"),silent=TRUE),"try-error")) 169 return(list(code=3,mess=paste("The setting for the 'collect' argument doesn't exist."))) 170 171 172 AMn<-nrow(x) 173 AMp<-ncol(x) 174 subbedout<-c(idvars,cs,ts) 175 176 if (is.null(idvars)) 177 idcheck <- c(1:AMp) 178 else 179 idcheck <- -idvars 180 181 ## Error Code: 4 182 ## Completely missing columns 183 184 if (any(colSums(!is.na(x[,idcheck])) <= 1)) { 185 all.miss <- colnames(x[,idcheck])[colSums(!is.na(x[,idcheck])) <= 1] 186 if (is.null(all.miss)) { 187 all.miss <- which(colSums(!is.na(x[,idcheck])) <= 1) 188 } 189 all.miss <- paste(all.miss, collapse = ", ") 190 error.code<-4 191 error.mess<-paste("The data has a column that is completely missing or only has one,observation. Remove these columns:", all.miss) 192 return(list(code=error.code,mess=error.mess)) 193 } 194 195 #Error codes: 5-6 196 #Errors in one of the list variables 197 idout<-listcheck(idvars,"One of the 'idvars'") 198 if (!identical(idout,0)) 199 return(list(code=(idout[[1]]+4),mess=idout[[2]])) 200 201 lagout<-listcheck(lags,"One of the 'lags'") 202 if (!identical(lagout,0)) 203 return(list(code=(lagout[[1]]+4),mess=lagout[[2]])) 204 205 leadout<-listcheck(leads,"One of the 'leads'") 206 if (!identical(leadout,0)) 207 return(list(code=(leadout[[1]]+4),mess=leadout[[2]])) 208 209 logout<-listcheck(logs,"One of the 'logs'") 210 if (!identical(logout,0)) 211 return(list(code=(logout[[1]]+4),mess=logout[[2]])) 212 213 sqout<-listcheck(sqrts,"One of the 'sqrts'") 214 if (!identical(sqout,0)) 215 return(list(code=(sqout[[1]]+4),mess=sqout[[2]])) 216 217 lgout<-listcheck(lgstc,"One of the 'lgstc'") 218 if (!identical(lgout,0)) 219 return(list(code=(lgout[[1]]+4),mess=lgout[[2]])) 220 221 tsout<-listcheck(ts,"The 'ts' variable") 222 if (!identical(tsout,0)) 223 return(list(code=(tsout[[1]]+4),mess=tsout[[2]])) 224 225 csout<-listcheck(cs,"The 'cs' variable") 226 if (!identical(csout,0)) 227 return(list(code=(csout[[1]]+4),mess=csout[[2]])) 228 229 nomout<-listcheck(noms,"One of the 'noms'") 230 if (!identical(nomout,0)) 231 return(list(code=(nomout[[1]]+4),mess=nomout[[2]])) 232 233 ordout<-listcheck(ords,"One of the 'ords'") 234 if (!identical(ordout,0)) # THIS FORMERLY READ "NOMOUT" 235 return(list(code=(ordout[[1]]+4),mess=ordout[[2]])) 236 237 # priors errors 238 if (!identical(priors,NULL)) { 239 240 # Error code: 7 241 # priors isn't a matrix 242 if (!is.matrix(priors)) { 243 error.code <- 7 244 error.mess <- "The priors argument is not a matrix." 245 return(list(code=error.code, mess=error.mess)) 246 } 247 248 # Error code: 8 249 # priors is not numeric 250 if (!is.numeric(priors)) { 251 error.code <- 7 252 error.mess <- paste("The priors matrix is non-numeric. It should\n", 253 "only have numeric values.") 254 return(list(code=error.code, mess=error.mess)) 255 256 } 257 258 # Error code: 47 259 # priors matrix has the wrong dimensions 260 if (ncol(priors) != 4 & ncol(priors) != 5) { 261 error.code <- 47 262 error.mess <- paste("The priors matrix has the wrong numberof columns.\n", 263 "It should have either 4 or 5 columns.",) 264 return(list(code=error.code, mess=error.mess)) 265 } 266 267 if (nrow(priors) > nrow(x)*ncol(x)) { 268 error.code <- 47 269 error.mess <- "There are more priors than there are observations." 270 return(list(code=error.code, mess=error.mess)) 271 } 272 273 274 # Error code: 48 275 # NAs in priors matrix 276 if (any(is.na(priors))) { 277 error.code <- 48 278 error.mess <- "There are missing values in the priors matrix." 279 return(list(code=error.code, mess=error.mess)) 280 } 281 282 # Error code: 49 283 # multiple priors set 284 if (any(duplicated(priors[,1:2]))) { 285 error.code <- 49 286 error.mess <- "Multiple priors set on one observation or variable." 287 return(list(code=error.code,mess=error.mess)) 288 } 289 290 prior.cols <- priors[,2] %in% c(1:ncol(x)) 291 prior.rows <- priors[,1] %in% c(0:nrow(x)) 292 293 ## Error code: 9 294 ## priors set for cells that aren't in the data 295 if (sum(c(!prior.cols,!prior.rows)) != 0) { 296 error.code <- 9 297 error.mess <- "There are priors set on cells that don't exist." 298 return(list(code=error.code,mess=error.mess)) 299 } 300 301 ## Error code: 59 302 ## no priors on nominal variables 303 if (any(priors[,2] %in% noms)) { 304 error.code <- 59 305 error.mess <- "Cannot set priors on nominal variables. " 306 return(list(code = error.code, mess = error.mess)) 307 } 308 309 ## Error code: 60 310 ## no priors on nominal variables 311 if (any(priors[,2] %in% idvars)) { 312 error.code <- 60 313 error.mess <- "Cannot set priors on ID variables. " 314 return(list(code = error.code, mess = error.mess)) 315 } 316 317 318 ## Error code: 12 319 ## confidences have to be in 0-1 320 if (ncol(priors) == 5) { 321 if (any(priors[,5] <= 0) || any(priors[,5] >= 1)) { 322 error.code<-12 323 error.mess<-paste("The priors confidences matrix has values that are less \n", 324 "than or equal to 0 or greater than or equal to 1.") 325 return(list(code=error.code,mess=error.mess)) 326 } 327 } 328 329 } 330 #Error code: 10 331 #Square roots with negative values 332 if (!is.null(sqrts)) { 333 if (sum(colSums(x[,sqrts, drop = FALSE] < 0, na.rm = T))) { 334 neg.vals <- colnames(x[,sqrts, drop = FALSE])[colSums(x[,sqrts, drop 335 = FALSE] < 0, na.rm = T) > 1] 336 if (is.null(neg.vals)) 337 neg.vals <- sqrts[colSums(x[,sqrts, drop = FALSE] < 0, na.rm = T) 338 > 1] 339 neg.vals <- paste(neg.vals, collapse = ", ") 340 error.code<-10 341 error.mess<-paste("The square root transformation cannot be used on variables with negative values. See column(s):", neg.vals) 342 return(list(code=error.code,mess=error.mess)) 343 } 344 } 345 346 347 #warning message 348 #logs with negative values 349 if (!is.null(logs)) { 350 triggered<-FALSE 351 for(localindex in 1:length(logs)){ 352 if(!triggered){ 353 if (any(na.omit(x[,logs[localindex]]) < 0)) { 354 warning(paste("The log transformation is being used on \n", 355 "variables with negative values. The values \n", 356 "will be shifted up by 1 plus the minimum value \n", 357 "of that variable.")) 358 triggered<-TRUE 359 } 360 } 361 } 362 } 363 364 365 #Error code: 11 366 #0-1 Bounds on logistic transformations 367 if (!identical(lgstc,NULL)) { 368 lgstc.check <- colSums(x[,lgstc,drop=FALSE] <= 0 | 369 x[,lgstc,drop=FALSE] >= 1, na.rm = TRUE) 370 if (sum(lgstc.check)) { 371 neg.vals <- colnames(x[,lgstc,drop=FALSE])[lgstc.check > 0] 372 if (is.null(neg.vals)) 373 neg.vals <- lgstc[lgstc.check > 0] 374 neg.vals <- paste(neg.vals, collapse = ", ") 375 error.code<-11 376 error.mess<-paste("The logistic transformation can only be used on values between 0 and 1. See column(s):", neg.vals) 377 return(list(code=error.code,mess=error.mess)) 378 } 379 380 } 381 382 #Error code: 12 383 #Confidence Intervals for priors bounded to 0-1 384 385 # if (!identical(conf,NULL)) { 386 # if (any(conf <= 0,conf>=1,na.rm=T)) { 387 # error.code<-12 388 # error.mess<-paste("The priors confidences matrix has values that are less \n", 389 # "than or equal to 0 or greater than or equal to 1.") 390 # return(list(code=error.code,mess=error.mess)) 391 # } 392 # } 393 394 #Error code: 13 395 #Can't set all variables to 'idvar' 396 if (!identical(idvars,NULL)) { 397 if ((AMp-1) <= length(idvars)) { 398 error.code<-13 399 error.mess<-paste("You cannot set all variables (or all but one) as ID variables.") 400 return(list(code=error.code,mess=error.mess)) 401 } 402 } 403 404 405 ## Error code: 14 406 ## ts canonot equal cs 407 if (!identical(ts,NULL) && !identical(cs,NULL)) { 408 if (ts==cs) { 409 error.code<-14 410 error.mess<-paste("Time series and cross-sectional variables cannot be the same.") 411 return(list(code=error.code,mess=error.mess)) 412 } 413 } 414 #Error code: 15 415 #TS is more than one integer 416 if (!identical(ts,NULL)) { 417 if (length(ts) > 1) { 418 error.code<-15 419 error.mess<-paste("The time series variable option is longer than one integer.") 420 return(list(code=error.code,mess=error.mess)) 421 } 422 } 423 #Error code: 16 424 #CS is more than one integer 425 if (!identical(cs,NULL)) { 426 if (length(cs) > 1) { 427 error.code<-16 428 error.mess<-paste("The cross section variable option is longer than one integer.") 429 return(list(code=error.code,mess=error.mess)) 430 } 431 } 432 433 ## if (!identical(casepri,NULL)) { 434 ## #Error code: 17 435 ## #Case prior must be in a matrix 436 ## if (!is.matrix(casepri)) { 437 ## error.code<-17 438 ## error.mess<-paste("The case priors should be in a martix form.") 439 ## return(list(code=error.code,mess=error.mess)) 440 ## } 441 ## #Error code: 18 442 ## #CS must be specified with case priors 443 ## if (identical(cs,NULL)) { 444 ## error.code<-18 445 ## error.mess<-paste("The cross-sectional variable must be set in order to use case priors.") 446 ## return(list(code=error.code,mess=error.mess)) 447 ## } 448 ## #Error code: 19 449 ## #Case priors have the wrong dimensions 450 ## if (sum(dim(casepri) == c(length(unique(data[,cs])),length(unique(data[,cs])))) != 2) { 451 ## error.code<-19 452 ## error.mess<-paste("The case priors have the wrong dimensions. It should \n", 453 ## "have rows and columns equal to the number of cases.") 454 ## return(list(code=error.code,mess=error.mess)) 455 ## } 456 ## #Error code: 20 457 ## #Case prior values are out of bounds 458 ## if (all(casepri != 0,casepri!=1,casepri!=2,casepri!=3)) { 459 ## error.code<-20 460 ## error.mess<-paste("The case priors can only have values 0, 1, 2, or 3.") 461 ## return(list(code=error.code,mess=error.mess)) 462 ## } 463 ## } 464 465 #check polynomials 466 if (!identical(polytime,NULL)) { 467 #Error code: 21 468 #Polynomials of time are longer than one integer 469 if (length(polytime) > 1) { 470 error.code<-21 471 error.mess<-paste("The polynomials of time setting is greater than one integer.") 472 return(list(code=error.code,mess=error.mess)) 473 } 474 if (!is.numeric(polytime)) { 475 error.code<-22 476 error.mess<-paste("The setting for polytime is not a number.") 477 return(list(code=error.code,mess=error.mess)) 478 } 479 if ((polytime %% 1) != 0) { 480 error.code<-23 481 error.mess<-paste("The number of polynomial terms to include for time (polytime) must be an integer.") 482 return(list(code=error.code,mess=error.mess)) 483 } 484 if (any(polytime > 3,polytime < 0)) { 485 error.code<-24 486 error.mess<-paste("The number of polynomial terms to include must be between 1 and 3.") 487 return(list(code=error.code,mess=error.mess)) 488 } 489 if (identical(ts,NULL)) { 490 error.code<-25 491 error.mess<-paste("You have set polynomials of time without setting the time series variable.") 492 return(list(code=error.code,mess=error.mess)) 493 } 494 if (all(!intercs,identical(polytime,0))) { 495 warning(paste("You've set the polynomials of time to zero with no interaction with \n", 496 "the cross-sectional variable. This has no effect on the imputation.")) 497 } 498 } 499 500 501 502 if (!identical(splinetime,NULL)) { 503 #Error code: 54 504 #Spline of time are longer than one integer 505 if (length(polytime) > 1) { 506 error.code<-54 507 error.mess<-paste("The spline of time setting is greater than one integer.") 508 return(list(code=error.code,mess=error.mess)) 509 } 510 if (!is.numeric(splinetime)) { 511 error.code<-55 512 error.mess<-paste("The setting for splinetime is not a number.") 513 return(list(code=error.code,mess=error.mess)) 514 } 515 if ((splinetime %% 1) != 0) { 516 error.code<-56 517 error.mess<-paste("The number of spline degrees of freedom to include for time (splinetime) must be an integer.") 518 return(list(code=error.code,mess=error.mess)) 519 } 520 if (any(splinetime > 6,splinetime < 0)) { 521 error.code<-57 522 error.mess<-paste("The number of spline degrees of freedom to include must be between 0 and 6.") 523 return(list(code=error.code,mess=error.mess)) 524 } 525 if (identical(ts,NULL)) { 526 error.code<-58 527 error.mess<-paste("You have set splines of time without setting the time series variable.") 528 return(list(code=error.code,mess=error.mess)) 529 } 530 if (all(!intercs,identical(polytime,0))) { 531 warning(paste("You've set the spline of time to zero with no interaction with \n", 532 "the cross-sectional variable. This has no effect on the imputation.")) 533 } 534 } 535 536 537 538 #checks for intercs 539 540 541 if (identical(intercs,TRUE)) { 542 if (identical(cs,NULL)) { 543 error.code<-27 544 error.mess<-paste("You have indicated an interaction with the cross section \n", 545 "without setting the cross section variable.") 546 return(list(code=error.code,mess=error.mess)) 547 } 548 if (length(unique(x[,cs])) > (1/3)*(AMn)) { 549 error.code<-28 550 error.mess<-paste("There are too many cross-sections in the data to use an \n", 551 "interaction between polynomial of time and the cross-section.") 552 return(list(code=error.code,mess=error.mess)) 553 } 554 if (sum(is.na(x[,cs])) > 0) { 555 error.code <- 60 556 error.mess <- 557 paste("There are missing values in the 'cs' variable.") 558 return(list(code=error.code,mess=error.mess)) 559 } 560 561 } 562 563 #Error codes: 29-31 564 #logical variable errors 565 interout<-logiccheck(intercs,"cross section interaction") 566 if (!identical(interout,0)) 567 return(list(code=(28+interout[[1]]),mess=interout[[2]])) 568 569 #p2sout<-logiccheck(p2s,"print to screen") 570 #if (!identical(p2sout,0)) 571 # return(list(code=(p2sout[[1]]+28),mess=p2sout[[2]])) 572 573 frout<-logiccheck(frontend,"frontend") 574 if (!identical(frout,0)) 575 return(list(code=(frout[[1]]+28),mess=frout[[2]])) 576 577 collout<-logiccheck(collect,"archive") 578 if (!identical(collout,0)) 579 return(list(code=(collout[[1]]+28),mess=collout[[2]])) 580 581 #Error code: 32 582 #Transformations must be mutually exclusive 583 if (length(unique(c(logs,sqrts,lgstc,noms,ords,idvars))) != length(c(logs,sqrts,lgstc,noms,ords,idvars))) { 584 error.code<-32 585 error.mess<-paste("Transfomations must be mutually exclusive, so one \n", 586 "variable can only be assigned one transformation. You have the \n", 587 "same variable designated for two transformations.") 588 return(list(code=error.code,mess=error.mess)) 589 } 590 591 #Error code: 33 592 #ts/cs variables can't be transformed 593 if (any(unique(c(logs,sqrts,lgstc,noms,ords,idvars)) == ts,unique(c(logs,sqrts,lgstc,noms,ords,idvars)) == cs)) { 594 error.code<-33 595 error.mess<-paste("The time series and cross sectional variables cannot be transformed.") 596 return(list(code=error.code,mess=error.mess)) 597 } 598 599 600 601 602 #Error code: 35 603 #tolerance must be greater than zero 604 if (tolerance <= 0) { 605 error.code<-35 606 error.mess<-paste("The tolerance option must be greater than zero.") 607 return(list(code=error.code,mess=error.mess)) 608 } 609 610 #check nominals 611 if (!identical(noms,NULL)) { 612 613 for (i in noms) { 614 #Error code: 36 615 #too many levels on noms 616 if (length(unique(na.omit(x[,i]))) > (1/3)*(AMn)) { 617 bad.var <- colnames(x)[i] 618 if (is.null(bad.var)) bad.var <- i 619 error.code<-36 620 error.mess<-paste("The number of categories in the nominal variable \'",bad.var,"\' is greater than one-third of the observations.", sep = "") 621 return(list(code=error.code,mess=error.mess)) 622 } 623 624 if (length(unique(na.omit(x[,i]))) > 10) 625 warning("\n\nThe number of categories in one of the variables marked nominal has greater than 10 categories. Check nominal specification.\n\n") 626 627 628 629 if (all(i==cs,intercs==TRUE)) { 630 noms<-noms[noms!=i] 631 warning("The cross sectional variable was set as a nominal variable. Its nominal status has been dropped.") 632 } 633 } 634 } 635 636 if (is.null(c(noms,ords,idvars,cs))) 637 fact <- c(1:AMp) 638 else 639 fact <- -c(noms,ords,idvars,cs) 640 641 if (is.null(c(cs,idvars))) 642 idcheck <- c(1:AMp) 643 else 644 idcheck <- -c(cs,idvars) 645 646 ##Error code: 37 647 ##factors out of the noms,ids,ords,cs 648 649 if (is.data.frame(x)) { 650 if (length(x[,fact])) { 651 if (sum(sapply(x[,fact],is.factor))) { 652 bad.var <- colnames(x[,fact])[sapply(x[,fact],is.factor)] 653 if (is.null(bad.var)) 654 bad.var <- setdiff(which(sapply(x,is.factor)), -fact) 655 bad.var <- paste(bad.var, collapse = ", ") 656 error.code<-37 657 error.mess<-paste("The following variable(s) are 'factors': ", 658 bad.var, 659 "You may have wanted to set this as a ID variable to remove it", 660 "from the imputation model or as an ordinal or nominal", 661 "variable to be imputed. Please set it as either and", 662 "try again.", sep = "\n") 663 return(list(code=error.code,mess=error.mess)) 664 665 } 666 if (sum(sapply(x[,fact],is.ordered))) { 667 bad.var <- colnames(x[,fact])[sapply(x[,fact],is.ordered)] 668 if (is.null(bad.var)) 669 bad.var <- setdiff(which(sapply(x,is.ordered)), -fact) 670 bad.var <- paste(bad.var, collapse = ", ") 671 error.code<-37 672 error.mess<-paste("The following variable(s) are 'factors': ", 673 bad.var, 674 "You may have wanted to set this as a ID variable to remove it", 675 "from the imputation model or as an ordinal or nominal", 676 "variable to be imputed. Please set it as either and", 677 "try again.", sep = "\n") 678 return(list(code=error.code,mess=error.mess)) 679 } 680 681 if (sum(sapply(x[,fact],is.character))) { 682 bad.var <- colnames(x[,fact])[sapply(x[,fact],is.character)] 683 if (is.null(bad.var)) 684 bad.var <- setdiff(which(sapply(x,is.character)), -fact) 685 bad.var <- paste(bad.var, collapse = ", ") 686 error.code<-38 687 error.mess<-paste("The following variable(s) are characters: ", 688 paste("\t",bad.var), 689 "You may have wanted to set this as a ID variable to remove it", 690 "from the imputation model or as an ordinal or nominal", 691 "variable to be imputed. Please set it as either and", 692 "try again.", sep = "\n") 693 694 return(list(code=error.code,mess=error.mess)) 695 } 696 } 697 } else { 698 if (!is.numeric(x)) { 699 error.code <- 38 700 error.mess <- paste("The \'x\' matrix is not numeric.") 701 return(list(code=error.code,mess=error.mess)) 702 } 703 } 704 #Error code: 39 705 #No missing observation 706 if (!any(is.na(x[,idcheck,drop=FALSE])) & is.null(overimp)) { 707 error.code<-39 708 error.mess<-paste("Your data has no missing values. Make sure the code for \n", 709 "missing data is set to the code for R, which is NA.") 710 return(list(code=error.code,mess=error.mess)) 711 } 712 713 #Error code: 40 714 #lags require ts 715 if (!is.null(lags)) { 716 if (is.null(ts)) { 717 error.code<-40 718 error.mess<-paste("You need to specify the time variable in order to create lags.") 719 return(list(code=error.code,mess=error.mess)) 720 } 721 } 722 723 #Error code: 41 724 #leads require ts 725 if (!is.null(leads)) { 726 if (is.null(ts)) { 727 error.code<-41 728 error.mess<-paste("You need to specify the time variable in order to create leads.") 729 return(list(code=error.code,mess=error.mess)) 730 } 731 } 732 733 734 #Error code: 42 735 #Only 1 column of data 736 if (AMp==1) { 737 error.code<-42 738 error.mess<-paste("There is only 1 column of data. Cannot impute.") 739 return(list(code=error.code,mess=error.mess)) 740 } 741 742 ## catch problems when the only other variable is an unused 743 ## cross-section. 744 if (!isTRUE(intercs) & ncol(x[,idcheck, drop = FALSE]) == 1) { 745 error.code<-42 746 error.mess<-paste("There is only 1 column of data. Cannot impute.") 747 return(list(code=error.code,mess=error.mess)) 748 } 749 ts.nulls <- is.null(polytime) & is.null(splinetime) 750 ts.zeros <- (polytime == 0) & (splinetime == 0) 751 if (!isTRUE(polytime > 0) & !isTRUE(splinetime > 0)) { 752 if (!isTRUE(intercs) & !is.null(ts)) { 753 if (ncol(x[,-c(ts,cs,idvars), drop = FALSE]) == 1) { 754 error.code<-61 755 error.mess<-paste("There is only 1 column of data after removing the ts, cs and idvars. Cannot impute without adding polytime.") 756 return(list(code=error.code,mess=error.mess)) 757 } 758 } 759 } 760 761 762 #Error code: 43 763 #Variable that doesn't vary 764 765 ## note that this will allow the rare case that a user only has 766 ## variation in a variable when all of the other variables are missing 767 ## in addition to having no variation in the listwise deleted 768 ## dataset. Our starting value function should be robust to this. 769 770 num.nonmissing <- function(obj) length(unique(na.omit(obj))) 771 if (is.data.frame(x)) { 772 non.vary <- sapply(x[,idcheck, drop = FALSE], num.nonmissing) 773 } else { 774 non.vary <- apply(x[,idcheck, drop = FALSE], 2, num.nonmissing) 775 } 776 777 if (sum(non.vary == 1)) { 778 non.names <- colnames(x[,idcheck])[non.vary == 1] 779 if (is.null(non.names)) { 780 hold <- rep(-1, ncol(x)) 781 hold[-idcheck] <- non.vary 782 non.names <- which(hold == 0) 783 } 784 non.names <- paste(non.names, collapse = ", ") 785 error.code<-43 786 error.mess<-paste("You have a variable in your dataset that does not vary. Please remove this variable. Variables that do not vary: ", non.names) 787 return(list(code=error.code,mess=error.mess)) 788 } 789 790 ## } else { 791 792 793 ## if (nrow(na.omit(x)) > 1) { 794 ## if (any(diag(var(x[,idcheck],na.rm=TRUE))==0)) { 795 ## error.code<-43 796 ## error.mess<-paste("You have a variable in your dataset that does not vary. Please remove this variable.") 797 ## return(list(code=error.code,mess=error.mess)) 798 ## } 799 ## } else { 800 ## for (i in 1:ncol(x[,idcheck])) { 801 ## if (var(x[,i],na.rm=TRUE) == 0) { 802 ## error.code<-43 803 ## error.mess<-paste("You have a variable in your dataset that does not vary. Please remove this variable.") 804 ## return(list(code=error.code,mess=error.mess)) 805 ## } 806 ## } 807 ## } 808 ## } 809 810 #checks for ordinals 811 if (!is.null(ords)) { 812 for (i in ords) { 813 #Error code: 44 814 # Ordinal variable with non-integers (factors work by design, and they're 815 # harder to check 816 if (!is.factor(x[,i])) { 817 if (any(unique(na.omit(x[,i])) %% 1 != 0 )) { 818 non.ints <- colnames(x)[i] 819 if (is.null(non.ints)) non.ints <- i 820 error.code<-44 821 error.mess<-paste("You have designated the variable \'",non.ints, 822 "\' as ordinal when it has non-integer values.", 823 sep = "") 824 return(list(code=error.code,mess=error.mess)) 825 } 826 } 827 } 828 } 829 830 831 832 ## #checks for outname 833 ## if (write.out==TRUE) { 834 ## if (!is.character(outname)) { 835 ## outname<-"outdata" 836 ## warning("The output filename (outname) was not a character. It has been set it 837 ## its default 'outdata' in the working directory.") 838 ## } 839 ## #Error code: 45 840 ## #output file errors 841 ## outtest<-try(write.csv("test",file=paste(outname,"1.csv",sep="")),silent=TRUE) 842 ## if (inherits(outtest,"try-error")) { 843 ## error.code<-45 844 ## error.mess<-paste("R cannot write to the outname you have specified. Please 845 ## check","that the directory exists and that you have permission to write.",sep="\n") 846 ## return(list(code=error.code,mess=error.mess)) 847 ## } 848 ## tmpdir<- strsplit(paste(outname,"1.csv",sep=""),.Platform$file.sep) 849 ## am.dir <- tmpdir[[1]][1] 850 ## if (length(tmpdir[[1]]) > 1) 851 ## for (i in 2:(length(tmpdir[[1]]))) 852 ## am.dir <- file.path(am.dir, tmpdir[[1]][i]) 853 ## file.remove(am.dir) 854 ## } 855 856 857 # if (xor(!identical(means,NULL),!identical(sds,NULL))) { 858 # means<-NULL 859 # sds<-NULL 860 # warning("Both the means and the SDs have to be set in order to use observational priors. The priors have been removed from the analysis.") 861 # } 862 # if (sum(!identical(mins,NULL),!identical(maxs,NULL),!identical(conf,NULL)) != 3 && 863 # sum(!identical(mins,NULL),!identical(maxs,NULL),!identical(conf,NULL)) != 0) { 864 # mins<-NULL 865 # maxs<-NULL 866 # conf<-NULL 867 # warning("Not all of the range parameters were set for the observational priors. They have been removed.") 868 # } 869 870 #checks of m 871 if (!is.numeric(m)) { 872 m<-5 873 warning("The number of imputations ('m') was a non-numeric. The value was changed to the default.") 874 } 875 if ((m %% 1) != 0) { 876 m<-5 877 warning("The number of imputation ('m') was not an integer. The value was changed to the default (5).") 878 } 879 if (m<=0) { 880 m<-5 881 warning("The number of imputations ('m') must be greater than 0. The value was changed to the default (5).") 882 } 883 884 885 # checks for bounds 886 if (!is.null(bounds)) { 887 b.size <- is.matrix(bounds) && ncol(bounds)==3 && nrow(bounds) > 0 888 b.cols <- sum(bounds[,1] %in% c(1:AMp)) == nrow(bounds) 889 maxint <- max.resample > 0 && (max.resample %% 1)==0 890 891 892 # Error 50: 893 # wrong sized bounds matrix 894 if (!b.size) { 895 error.code<-50 896 error.mess<-paste("The bounds argument is a three-column matrix.") 897 return(list(code=error.code,mess=error.mess)) 898 } 899 900 # Error 51: 901 # nonexistant columns in bounds. 902 if (!b.cols) { 903 error.code<-51 904 error.mess<-paste("One of the bounds is on a non-existant column.") 905 return(list(code=error.code,mess=error.mess)) 906 } 907 908 # Error 52: 909 # max.resample needs to be positive integer. 910 if (!maxint) { 911 error.code<-52 912 error.mess<-paste("The max.resample argument needs to be a positive integer.") 913 return(list(code=error.code,mess=error.mess)) 914 } 915 } 916 917 if (!is.null(overimp)) { 918 o.num <- is.numeric(overimp) 919 o.size <- (is.matrix(overimp) & ncol(overimp) == 2) | length(overimp) == 2 920 o.cols <- all(unique(overimp[,2]) %in% 1:ncol(x)) 921 o.rows <- all(unique(overimp[,1]) %in% 1:nrow(x)) 922 923 ## Error 53: 924 ## overimp not numeric 925 if (!o.num | !o.size) { 926 error.code <- 53 927 error.mess <- "The overimp matrix needs to be a two-column numeric matrix." 928 return(list(code=error.code,mess=error.mess)) 929 } 930 931 ## Error 54: 932 ## overimp out of range 933 if (!o.rows | !o.cols) { 934 error.code <- 54 935 error.mess <- "A row/column pair in overimp is outside the range of the data." 936 return(list(code=error.code,mess=error.mess)) 937 } 938 939 } 940 941 if (is.data.frame(x)) { 942 is.posix <- function(x) inherits(x, c("POSIXt", "POSIXct", "POSIXlt")) 943 posix.check <- sapply(x, is.posix) 944 if (any(is.na(x[, posix.check]))) { 945 stop("NA in POSIXt variable: remove or convert to numeric") 946 } 947 } 948 949 950 if (!is.null(emburn)) { 951 if (length(emburn) != 2) { 952 stop("emburn must be length 2") 953 } 954 } 955 956 if (!is.null(boot.type)) { 957 if (!(boot.type %in% c("ordinary", "none"))) { 958 stop("boot.type must be either 'ordinary' or 'none'") 959 } 960 } 961 962 if (is.data.frame(x)) { 963 if (sum(sapply(x, length) == 0)) { 964 bad.var <- colnames(x)[sapply(x,length) == 0] 965 if (is.null(bad.var)) 966 bad.var <- which(sapply(x,length) == 0) 967 bad.var <- paste(bad.var, collapse = ", ") 968 error.code <- 53 969 error.mess<-paste("The variable(s)",bad.var,"have length 0 in the data frame. Try removing these variables or reimporting the data.") 970 return(list(code=error.code,mess=error.mess)) 971 } 972 } 973 974 if (nrow(na.omit(x[,idcheck,drop=FALSE])) > ncol(x[,idcheck,drop=FALSE])) { 975 if (is.data.frame(x)) { 976 lmcheck <- lm(I(rnorm(AMn))~ ., data = x[,idcheck, drop = FALSE]) 977 } else { 978 lmcheck <- lm(I(rnorm(AMn))~ ., data = as.data.frame(x[,idcheck, drop = FALSE])) 979 } 980 if (any(is.na(coef(lmcheck)))) { 981 bad.var <- names(coef(lmcheck))[which(is.na(coef(lmcheck)))] 982 if (length(bad.var) == 1) { 983 warning(paste("The variable", bad.var, "is perfectly collinear with another variable in the data.\n")) 984 } else { 985 bad.var <- paste(bad.var, collapse = ", ") 986 warning(paste("The variables (or variable with levels)", bad.var, "are perfectly collinear with another variable in the data.\n")) 987 } 988 989 } 990 } 991 992 return(list(m=m,priors=priors)) 993} 994