Add option to checkpoint every evaluation
[openmx:openmx.git] / R / MxRestore.R
1 #
2 #   Copyright 2007-2014 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 removeTrailingSeparator <- function(x) {
17         return(sub('/$', '', x))
18 }
19
20 mxSave <- function(model, chkpt.directory = ".", chkpt.prefix = "") {
21         if (!is(model, "MxModel")) {
22                 stop("'model' argument must be a MxModel object")
23         }
24         chkpt.directory <- removeTrailingSeparator(chkpt.directory)
25         chkpt.filename <- paste(chkpt.prefix, model@name, ".omx", sep = '')
26         filepath <- paste(chkpt.directory, chkpt.filename, sep = '/')
27         print.header <- file.access(filepath) != 0
28         pList <- omxGetParameters(model)
29         if (length(model@output) == 0) {
30                 iterations <- 0
31                 objective <- as.numeric(NA)
32         } else {
33                 iterations <- model@output$iterations
34                 objective <- model@output$minimum
35         }
36         timestamp <- date()
37         fconnection <- file(filepath, "a")
38         if (!isOpen(fconnection, "w")) {
39                 return(FALSE)
40         }
41         if (print.header) {
42                 cat("iterations\t", file=fconnection)
43                 cat("timestamp\t", file=fconnection)
44                 cat("objective\t", file=fconnection)
45                 if (length(pList) > 0) {
46                         for(i in 1:length(pList)) {
47                                 cat(omxQuotes(names(pList)[[i]]), file=fconnection)
48                                 cat("\t", file=fconnection)
49                         }
50                 }
51                 cat("\n", file=fconnection)
52         }
53         cat(iterations, file=fconnection)
54         cat("\t", file=fconnection)
55         cat(omxQuotes(timestamp), file=fconnection)
56         cat("\t", file=fconnection)
57         cat(objective, file=fconnection)
58         cat("\t", file=fconnection)
59         if (length(pList) > 0) {
60                 for(i in 1:length(pList)) {
61                         cat(pList[[i]], file=fconnection)
62                         cat("\t", file=fconnection)
63                 }
64         }
65         cat("\n", file=fconnection)
66         close(fconnection)
67         return(TRUE)
68 }
69
70 mxRestore <- function(model, chkpt.directory = ".", chkpt.prefix = "") {        
71         if (!is(model, "MxModel")) {
72                 stop("'model' argument must be a MxModel object")
73         }
74         chkpt.directory <- removeTrailingSeparator(chkpt.directory)
75         pattern <- paste("^\\Q", chkpt.prefix, "\\E.*(\\.omx)$", sep = '')
76         chkpt.files <- list.files(chkpt.directory, full.names = FALSE)
77         chkpt.files <- grep(pattern, chkpt.files, perl=TRUE, value=TRUE)
78         if(length(chkpt.files) == 0) {
79                 return(model)
80         }
81         namespace <- imxGenerateNamespace(model)
82         flatModel <- imxFlattenModel(model, namespace)
83         dependencies <- cycleDetection(flatModel)
84         dependencies <- transitiveClosure(flatModel, dependencies)
85         flatModel <- generateParameterList(flatModel, dependencies, list())
86         for(i in 1:length(chkpt.files)) {
87                 filename <- chkpt.files[[i]]
88                 modelname <- substr(filename, nchar(chkpt.prefix) + 1, nchar(filename) - 4)
89                 filepath <- paste(chkpt.directory, filename, sep = '/')
90                 checkpoint <- read.table(filepath, header=TRUE, stringsAsFactors=FALSE, check.names=FALSE, sep="\t")
91                 model <- restoreCheckpointModel(model, modelname, checkpoint, flatModel)
92         }
93         return(model)
94 }
95
96 restoreCheckpointModel <- function(model, modelname, checkpoint, flatModel) {
97         if (model@independent) {
98                 namespace <- imxGenerateNamespace(model)
99                 flatModel <- imxFlattenModel(model, namespace)
100         }
101         if (modelname == model@name) {
102                 ign <- match(c("OpenMxContext","OpenMxNumFree","OpenMxEvals","iterations","timestamp","objective"),
103                              colnames(checkpoint))
104                 ign <- ign[!is.na(ign)]
105                 values <- as.numeric(checkpoint[nrow(checkpoint), -ign])
106                 model <- imxUpdateModelValues(model, flatModel, values)
107         }
108         model@submodels <- lapply(model@submodels, restoreCheckpointModel, modelname, checkpoint, flatModel)
109         return(model)
110 }
111