#====================================================================
## First, things that are more nearly flow-control constructs than
## "commands" in the usual sense
ado_cmd_quit <-
function(context)
{
#Don't do anything with context$debug_match_call because otherwise we can't get
#out of ado() when using that flag to test
raiseCondition("Exit requested", "ExitRequestedException")
}
ado_cmd_continue <-
function(context, option_list=NULL)
{
#Similarly, we shouldn't return match.call here because
#then it's impossible to test loops properly, and this command
#is pretty simple: its arguments are hard to screw up.
valid_opts <- c("break")
option_list <- validateOpts(option_list, valid_opts)
brk <- hasOption(option_list, "break")
if(brk)
raiseCondition("Break", "BreakException")
else
raiseCondition("Continue", "ContinueException")
}
ado_cmd_do <-
function(context, expression_list)
{
if(context$debug_match_call)
return(match.call())
filename <- as.character(expression_list[[1]])
if(tools::file_ext(filename) == "")
{
filename <- filename %p% ".do"
}
#Set numbered macros if there are any
if(length(expression_list) > 1)
{
vals <- expression_list[2:length(expression_list)]
inds <- seq_along(vals)
for(ind in inds)
{
mname <- as.symbol(as.character(ind))
val <- as.character(vals[ind])
ado_cmd_local(context=context, expression_list=list(mname, val))
}
}
#Set up the connection and execute what's in it, echoing the commands
#even if we're interactive and that normally wouldn't be done.
con <- file(filename, "rb")
on.exit(close(con), add=TRUE)
context$interpret(con, echo=1)
#Finally, tear down the numbered macros
if(length(expression_list) > 1)
{
for(ind in inds)
{
mname <- as.symbol(as.character(ind))
ado_cmd_local(context=context, expression_list=list(mname))
}
}
return(invisible(TRUE))
}
#The if expr { } construct
ado_cmd_if <-
function(context, expression, compound_cmd)
{
if(context$debug_match_call)
return(match.call())
}
ado_cmd_exit <- ado_cmd_quit
ado_cmd_run <- ado_cmd_do
#====================================================================
## Now, more normal commands
ado_cmd_about <-
function(context)
{
if(context$debug_match_call)
return(match.call())
fields <- c("Package", "Authors@R", "Version", "Title", "License", "URL", "BugReports")
desc <- utils::packageDescription(utils::packageName(), fields=fields)
return(structure(desc, class=c("ado_cmd_about", class(desc))))
}
ado_cmd_sleep <-
function(context, expression)
{
if(context$debug_match_call)
return(match.call())
Sys.sleep(expression[[1]])
return(invisible(NULL))
}
ado_cmd_display <-
function(context, expression)
{
if(context$debug_match_call)
return(match.call())
ret <- eval(expression[[1]])
return(structure(ret, class=c("ado_cmd_display", class(ret))))
}
ado_cmd_preserve <-
function(context, option_list=NULL)
{
if(context$debug_match_call)
return(match.call())
valid_opts <- c("memory")
option_list <- validateOpts(option_list, valid_opts)
mem <- hasOption(option_list, "memory")
context$dta$preserve(memory=mem)
return(invisible(NULL))
}
ado_cmd_restore <-
function(context, option_list=NULL)
{
if(context$debug_match_call)
return(match.call())
valid_opts <- c("not")
option_list <- validateOpts(option_list, valid_opts)
cancel <- hasOption(option_list, "not")
context$dta$restore(cancel=cancel)
return(invisible(NULL))
}
ado_cmd_query <-
function(context, varlist=NULL)
{
if(context$debug_match_call)
return(match.call())
#Subcommand is accepted for compatibility but (currently) ignored.
#If the list of settings settles down in the future, we might implement
#groups of them that this command can print selectively, the way Stata does.
raiseifnot(is.null(varlist) || length(varlist) == 1,
msg="Wrong number of arguments to query")
return(structure(context$settings_all(), class="ado_cmd_query"))
}
ado_cmd_set <-
function(context, expression_list=NULL)
{
if(context$debug_match_call)
return(match.call())
if(is.null(expression_list))
{
return(ado_cmd_query(context=context))
}
raiseifnot(length(expression_list) == 2,
msg="Wrong number of arguments to set")
setting <- expression_list[[1]]
raiseifnot(is.symbol(setting) || is.character(setting),
msg="Bad setting name")
if(is.symbol(setting))
{
setting <- as.character(setting)
}
value <- expression_list[[2]]
if(!is.numeric(value))
{
value <- as.character(value)
}
#Need to handle some settings (seed, rng, rngstate, obs) which affect
#the R interpreter's internal state, or the dataset object's state,
#differently from other settings.
if(setting == "seed")
{
if(!is.numeric(value))
{
raiseCondition("Bad seed value")
}
set.seed(value)
} else if(setting == "rng")
{
if(is.numeric(value))
{
raiseCondition("Bad RNG kind value")
}
RNGkind(kind=value)
} else if(setting == "rngstate")
{
if(is.numeric(value))
{
raiseCondition("Bad RNG state")
}
#Deparse the representation in c(rngstate)
val <- strsplit(value, ",", fixed=TRUE)[[1]]
val <- vapply(val, as.numeric, numeric(1))
.Random.seed <- val
} else if(setting == "obs")
{
if(!is.numeric(value))
{
raiseCondition("Bad # of obs to set")
}
context$dta$set_obs(value)
} else
{
context$setting_set(setting, value)
}
return(invisible(NULL))
}
ado_cmd_creturn <-
function(context, expression)
{
if(context$debug_match_call)
return(match.call())
#Must be invoked as "creturn list"
if(as.character(expression[[1]]) != "list")
{
raiseCondition("Unrecognized subcommand")
}
#Get the values and put them into a list with their names as
#the list names. This format is easier for the print method
#to work with.
nm <- ado_func_c(context=context, enum=TRUE)
vals <- lapply(nm, function(x) ado_func_c(context=context, val=x))
names(vals) <- nm
return(structure(vals, class="ado_cmd_creturn"))
}
ado_cmd_return <-
function(context, expression)
{
if(context$debug_match_call)
return(match.call())
#Must be invoked as "return list"
if(as.character(expression[[1]]) != "list")
{
raiseCondition("Unrecognized subcommand")
}
nm <- ado_func_r(context=context, enum=TRUE)
vals <- lapply(nm, function(x) ado_func_r(context=context, val=x))
names(vals) <- nm
return(structure(vals, class="ado_cmd_return"))
}
ado_cmd_ereturn <-
function(context, expression)
{
if(context$debug_match_call)
return(match.call())
#Must be invoked as "ereturn list"
if(as.character(expression[[1]]) != "list")
{
raiseCondition("Unrecognized subcommand")
}
nm <- ado_func_e(context=context, enum=TRUE)
vals <- lapply(nm, function(x) ado_func_e(context=context, val=x))
names(vals) <- nm
return(structure(vals, class="ado_cmd_ereturn"))
}
ado_cmd_log <-
function(context, expression_list=NULL, using_clause=NULL, option_list=NULL)
{
if(context$debug_match_call)
return(match.call())
valid_opts <- c("append", "replace", "text", "smcl", "name")
option_list <- validateOpts(option_list, valid_opts)
raiseif(!is.null(using_clause) && !is.null(expression_list),
msg="Cannot specify using clause and a subcommand")
if(is.null(using_clause) && is.null(expression_list))
{
raiseifnot(is.null(option_list), msg="Cannot specify options here")
msg <- "Open logging sinks: \n\n"
for(con in context$log_sinks())
{
msg <- msg %p% con
}
return(msg)
} else if(!is.null(using_clause))
{
raiseif(hasOption(option_list, "smcl"), msg="SMCL is not supported")
context$log_register_sink(using_clause, type="log")
} else #we have a subcommand
{
raiseifnot(is.null(option_list), msg="Cannot specify options here")
cmd <- as.character(expression_list[[1]])
raiseifnot(cmd %in% c("query", "close", "off", "on"))
if(cmd == "query")
{
msg <- "Open logging sinks: \n\n"
for(con in context$log_sinks())
{
msg <- msg %p% con
}
return(msg)
} else if(cmd == "close")
{
raiseif(length(expression_list) %not_in% c(1,2),
msg="Incorrect number of arguments to log close")
if(length(expression_list) == 1)
{
context$log_deregister_all_sinks(type="log")
} else
{
context$log_deregister_sink(as.character(expression_list[[2]]))
}
} else if(cmd == "on")
{
context$log_set_enabled(TRUE)
} else if(cmd == "off")
{
context$log_set_enabled(FALSE)
}
}
return(invisible(NULL))
}
ado_cmd_cmdlog <-
function(context, expression_list=NULL, using_clause=NULL, option_list=NULL)
{
if(context$debug_match_call)
return(match.call())
valid_opts <- c("append", "replace", "permanently")
option_list <- validateOpts(option_list, valid_opts)
raiseif(!is.null(using_clause) && !is.null(expression_list),
msg="Cannot specify using clause and a subcommand")
if(is.null(using_clause) && is.null(expression_list))
{
raiseifnot(is.null(option_list), msg="Cannot specify options here")
msg <- "Open command logging sinks: \n\n"
for(con in context$log_cmdlog_sinks())
{
msg <- msg %p% con
}
return(msg)
} else if(!is.null(using_clause))
{
raiseif(hasOption(option_list, "permanently"),
msg="Permanent option setting is not supported")
context$log_register_sink(using_clause, type="cmdlog")
} else #we have a subcommand
{
raiseifnot(is.null(option_list), msg="Cannot specify options here")
cmd <- as.character(expression_list[[1]])
raiseifnot(cmd %in% c("close", "off", "on"))
if(cmd == "close")
{
raiseif(length(expression_list) %not_in% c(1,2),
msg="Incorrect number of arguments to cmdlog close")
if(length(expression_list) == 1)
{
context$log_deregister_all_sinks(type="cmdlog")
} else
{
context$log_deregister_sink(as.character(expression_list[[2]]))
}
} else if(cmd == "on")
{
context$log_cmdlog_set_enabled(TRUE)
} else if(cmd == "off")
{
context$log_cmdlog_set_enabled(FALSE)
}
}
return(invisible(NULL))
}
ado_cmd_help <-
function(context, expression)
{
if(context$debug_match_call)
return(match.call())
}
ado_cmd_di <- ado_cmd_display
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.