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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
#' Utility tools for M2
#'
#' Utility tools for M2
#'
#' @param x an object of class \code{m2}
#' @param m2_attr the name of an M2 attribute
#' @param name a string; the name of a M2 object
#' @param value the value to assign
#' @param m2_name \code{m2_name} M2 attribute
#' @param m2_class \code{m2_class} M2 attribute
#' @param base_class a base class; an R class to use for dispatching
#' if there is no relevant method for the other classes (e.g.
#' \code{m2})
#' @param m2_meta \code{m2_meta} M2 attribute
#' @param all.names if \code{TRUE}, all registered Macaulay2
#' variables, including ones internally used by m2r, will be
#' returned
#' @name m2_utility
#' @examples
#'
#' \dontrun{ requires Macaulay2
#'
#' m2("a = 5")
#' m2_ls()
#' m2_exists("a")
#' m2("b = 1")
#' m2_exists(c("a","b","c"))
#'
#' m2_getwd()
#'
#' x <- 1
#' class(x) <- "m2"
#' attr(x, "m2_meta") <- list(a = 1, b = 2)
#' m2_meta(x)
#' m2_meta(x, "b")
#' m2_meta(x, "b") <- 5
#' m2_meta(x, "b")
#'
#' # R <- ring(c("x1", "x2", "x3"))
#' # m2_name(R)
#' # m2(sprintf("class %s", m2_name(R)))
#' # m2_ls()
#' # m2_rm(m2_name(R))
#' # m2_ls()
#' # m2(paste("class", m2_name(R)))
#'
#' m2_ls()
#' m2_ls(all.names = TRUE)
#'
#'
#' }
#' @rdname m2_utility
#' @export
m2_name <- function (x) {
if ( is.m2(x) ) {
attr(x, "m2_name")
} else {
character(0)
}
}
#' @rdname m2_utility
#' @export
`m2_name<-` <- function (x, value) {
stopifnot( is.m2(x) )
attr(x, "m2_name") <- value
x
}
#' @rdname m2_utility
#' @export
m2_meta <- function (x, m2_attr) {
if ( !is.m2(x) ) return(NULL)
if ( missing(m2_attr) ) return(attr(x, "m2_meta"))
attr(x, "m2_meta")[[m2_attr]]
}
#' @rdname m2_utility
#' @export
`m2_meta<-` <- function (x, m2_attr, value) {
stopifnot( is.m2(x) )
if (missing(m2_attr)) {
attr(x, "m2_meta") <- value
} else {
meta <- m2_meta(x)
meta[[m2_attr]] <- value
attr(x, "m2_meta") <- meta
}
x
}
#' @rdname m2_utility
#' @export
m2_structure <- function (x = NA, m2_name, m2_class, m2_meta, base_class) {
if (!missing(m2_class)) class(x) <- c(m2_class, "m2")
if (!missing(base_class)) class(x) <- c(class(x), base_class)
if (!missing(m2_name)) m2_name(x) <- m2_name
# if (m2_meta(x) != NULL) m2_meta(x)
if (!missing(m2_meta)) m2_meta(x) <- m2_meta
x
}
#' @rdname m2_utility
#' @export
m2_exists <- function(name) {
if(!is.character(name)) name <- deparse(substitute(name))
name %in% m2_ls()
}
#' @rdname m2_utility
#' @export
m2_ls <- function(all.names = FALSE) {
out <- m2("userSymbols()")
out <- str_sub(out, 2, -2)
out <- str_split(out, ",")[[1]]
# "symbols m2o1" -> "m2o1"
out <- str_sub(out, 8)
# remove internals and m2o#'s
if(!all.names) {
out <- out[!str_detect(out, "m2rint")]
out <- out[!str_detect(out, "m2o[0-9]+")]
}
# return
out
}
#' @rdname m2_utility
#' @export
m2_rm <- function(name) {
stop("broken.")
if (!is.m2(name)) return(invisible())
m2(paste(m2_name(name), "=symbol", m2_name(name)))
invisible()
}
#' @rdname m2_utility
#' @export
m2_getwd <- function() {
str_sub(m2("currentDirectory()"), 2, -2)
}
|
