-
Notifications
You must be signed in to change notification settings - Fork 7
/
genmodel.R
135 lines (106 loc) · 3.57 KB
/
genmodel.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
#' Generate a configuration matrix
#'
#' genmodel runs 4ti2's genmodel program to compute the configuration matrix A
#' corresponding to graphical statistical models given by a simplicial complex
#' and levels on the nodes.
#'
#' @param varlvls a vector containing the number of levels of each variable
#' @param facets the facets generating the hierarchical model, a list of vectors
#' of variable indices
#' @param dir Directory to place the files in, without an ending /
#' @param quiet If FALSE, messages the 4ti2 output
#' @param shell Messages the shell code used to do the computation
#' @param ... Additional arguments to pass to the function
#' @return The configuration matrix of the model provided
#' @export
#' @examples
#'
#' if (has_4ti2()) {
#'
#' varlvls <- rep(2, 2)
#' facets <- list(1, 2)
#' genmodel(varlvls, facets)
#' genmodel(varlvls, facets, quiet = FALSE)
#'
#' varlvls <- rep(3, 3)
#' facets <- list(1:2, 2:3, c(3,1))
#' genmodel(varlvls, facets)
#'
#' # compare this to algstat's hmat function
#'
#' }
#'
genmodel <- function(varlvls, facets, dir = tempdir(), quiet = TRUE,
shell = FALSE, ...
){
if (!has_4ti2()) missing_4ti2_stop()
## compute other args
opts <- as.list(match.call(expand.dots = FALSE))[["..."]]
if (is.null(opts)) {
opts <- ""
} else {
opts <- str_c("-", names(opts), "", unlist(opts))
opts <- str_c(opts, collapse = " ")
}
## compute/write 4ti2 code file
####################################
## format varlvls
formatted_varlvls <- str_sub(format_latte(t(varlvls)), 3)
## format simplices
formatted_facets <- vapply(
facets,
function(v) paste(length(v), paste(v, collapse = " ")),
character(1)
)
formatted_facets <- paste(
length(facets),
paste(formatted_facets, collapse = "\n"),
sep = "\n"
)
## bring the two together
code <- paste(formatted_varlvls, formatted_facets, sep = "\n")
## make dir to put 4ti2 files in (within the tempdir) timestamped
dir.create(scratch_dir <- file.path(dir, time_stamp()))
## make 4ti2 file
writeLines(code, con = file.path(scratch_dir, "PROJECT.mod"))
## move to dir and run 4it2 genmodel
####################################
## switch to temporary directory
user_working_directory <- getwd()
setwd(scratch_dir); on.exit(setwd(user_working_directory), add = TRUE)
## run 4ti2
if (is_mac() || is_unix()) {
system2(
file.path(get_4ti2_path(), "genmodel"),
paste(opts, file.path(scratch_dir, "PROJECT")),
stdout = "genmodel_out",
stderr = "genmodel_err"
)
# generate shell code
shell_code <- glue(
"{file.path(get_4ti2_path(), 'genmodel')} {paste(opts, file.path(scratch_dir, 'PROJECT'))} > genmodel_out 2> genmodel_err"
)
if(shell) message(shell_code)
} else if (is_win()) {
matFile <- file.path(scratch_dir, "PROJECT")
matFile <- chartr("\\", "/", matFile)
matFile <- str_c("/cygdrive/c", str_sub(matFile, 3))
system2(
"cmd.exe",
glue("/c env.exe {file.path(get_4ti2_path(), 'genmodel')} {opts} {matFile}"),
stdout = "genmodel_out",
stderr = "genmodel_err"
)
# generate shell code
shell_code <- glue(
"cmd.exe /c env.exe {file.path(get_4ti2_path(), 'genmodel')} {opts} {matFile} > genmodel_out 2> genmodel_err"
)
if(shell) message(shell_code)
}
## print output, if desired
if(!quiet) message(paste0(readLines("genmodel_out"), "\n"))
std_err <- readLines("genmodel_err")
if(any(std_err != "")) warning(str_c(std_err, collapse = "\n"), call. = FALSE)
## read and return
read.latte(paste0("PROJECT", ".mat"))
}