/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (c) 2016-2019, VU University Amsterdam
CWI, Amsterdam
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(r_call,
[ (<-)/2, % ?Var, +Expression
(<-)/1, % +Expression
r_call/2, % +Function, +Options
% Internal predicates
r/4, % Quasi quotation parser
r_execute/3, % +Assignments, +Command, -Result
r_setup_graphics/2, % +Rconn, +Format
op(900, fx, <-),
op(900, xfx, <-),
op(400, yfx, $),
op(100, yf, [])
]).
:- use_module(r_serve).
:- use_module(r_grammar).
:- use_module(r_term).
:- use_module(library(apply)).
:- use_module(library(error)).
:- use_module(library(lists)).
:- use_module(library(debug)).
:- use_module(library(quasi_quotations)).
:- use_module(library(dcg/basics)).
:- use_module(library(settings)).
:- use_module(library(option)).
:- multifile
r_init_session/1, % +Session
r_console/2, % +Type, ?Term
r_console_property/1, % ?Property
r_display_images/1. % +Images
/** <module> R plugin for SWISH
This module make R available to SWISH using the
[Rserve](https://rforge.net/Rserve/) R package. The module r_serve.pl
implements a SWI-Prolog wrapper around the Rserve C++ client to realise
the communication with the R server.
The Prolog view at R is inspired by
[real](http://stoics.org.uk/~nicos/sware/real/) from Nicos Angelopoulos.
It consists of the following two predicates:
- Var <- Expression
Assign the result of evaluating the given R Expression to Var. Var
can be a Prolog variable or an R expression.
- <- Expression
Evaluate expression, discarding the result. Possible console output
is captured.
In addition, the _quasi quotation_ `r` is defined. The quasi quotation
takes Prolog variables as arguments and an R expression as content.
Arguments (Prolog variable names) that match R identifiers cause the
temporary of an R variable with that name bound to the translated Prolog
value. R quasi quotations can be used as isolated goals, as well as as
right-hand arguments to <-/2 and <-/1. The example below calls the R
plot() function on the given Prolog list.
```
?- numlist(1,10,Data),
{|r(Data)||plot(Data)|}.
```
Images created by the R session are transferred as SVG and sent to the
SWISH console using pengine_output/1.
*/
:- setting(rserve:socket, atom, '/home/rserve/socket',
"Unix domain socket for connecting to Rserve").
:- setting(rserve:host, atom, '127.0.0.1',
"Host for connecting to Rserve").
:- setting(rserve:port, integer, 6311,
"Port for connecting to Rserve").
%% (Var <- Expression) is det.
%
% Assign the result of evaluating the given R Expression to Var.
% Var can be a Prolog variable or an R expression.
Var <- Expression :-
var(Var), !,
( var(Expression)
-> instantiation_error(Expression)
; Expression = r_execute(Assignments, Command, Var)
-> r_execute(Assignments, Command, Var)
; phrase(r_expression(Expression, Assignments), Command)
-> r_execute(Assignments, Command, Var)
; domain_error(r_expression, Expression)
).
Var <- Expression :-
( atom(Var),
r_primitive_data(Expression)
-> r_assign($, Var, Expression)
; <-(Var<-Expression)
).
r_primitive_data(Data) :-
is_list(Data), !.
r_primitive_data(Data) :-
compound(Data), !, fail.
%% (<- Expression) is det.
%
% Evaluate Expression, discarding the result. Possible console
% output is captured using the R function `capture.output`.
<- Term :-
( var(Term)
-> instantiation_error(Term)
; Term = r_execute(Assignments, Command, _Var)
-> r_capture_output(Assignments, Command)
; phrase(r_expression(Term, Assignments), Command)
-> r_capture_output(Assignments, Command)
; domain_error(r_expression, Term)
).
%% r_capture(Assignments, Command)
%
% Execute Command, presenting the R console output to the (Prolog)
% user.
r_capture_output(Assignments, Command) :-
to_string(Command, CommandS),
r_assign($, 'Rserve.cmd', CommandS),
r_execute(Assignments,
"capture.output(eval(parse(text=Rserve.cmd)))",
Output),
emit_r_output(Output).
to_string(Command, CommandS) :-
string(Command), !,
CommandS = Command.
to_string(Command, CommandS) :-
string_codes(CommandS, Command).
emit_r_output(Output) :-
r_console(stdout, Output), !.
emit_r_output(Output) :-
maplist(writeln, Output).
%! r_call(+Fun, +Options)
%
% Construct and possibly call an R function. Fun can be an atom or
% a compound, eg plot, or plot(width=3). The predicate also
% supports multiple output destinations. Options processed:
%
% - call(Bool)
% If `false` (default `true`), do __not__ call the result.
% - fcall(-Term)
% Term is unified with the constructed call
% - rvar(Var)
% Variable for the output
%
% @compat This is a partial implementation of the corresponding
% [real](http://www.swi-prolog.org/pack/file_details/real/prolog/real.pl) predicate.
r_call(Func, Options) :-
partition(eq_pair, Options, XArgs, Options1),
extend(Func, XArgs, Call),
option(fcall(Call), Options1, _),
( option(call(true), Options1, true)
-> ( option(rvar(Var), Options1)
-> Var <- Call
; <- Call
)
; true
).
eq_pair(_=_).
extend(Compound, XArgs, Term) :-
compound(Compound), !,
compound_name_arguments(Compound, Func, Args0),
append(Args0, XArgs, Args),
compound_name_arguments(Term, Func, Args).
extend(Atom, XArgs, Term) :-
compound_name_arguments(Term, Atom, XArgs).
%% r_console(+Stream, ?Term)
%
% Hook console interaction. Currently only used for <-/1 to emit
% the captured output. In this cases, Stream is `stdout` and Term
% is a list of strings, each representing a line of output. The
% list can be empty. If the hook fails, maplist(writeln, Term) is
% called to write the output to `current_output`.
%% r_execute(+Assignments, +Command, -Result) is det.
%
% Execute the R command Command after binding the variables in
% Assignments and unify the result with Result.
%
% @arg Assignments is a list of Name=Value, where Name must be a
% valid R indentifier.
% @arg Command is a string holding the R command to execute
r_execute(Assignments, Command, Result) :-
r_setup_console($),
setup_call_cleanup(
maplist(r_bind, Assignments),
r_eval_ex($, Command, Result),
r_unbind(Assignments)),
r_send_images.
r_bind(RVar=Value) :-
r_assign($, RVar, Value).
%% r_unbind(+Bindings)
%
% Remove the created bindings from the R environment
r_unbind([]) :- !.
r_unbind(Bindings) :-
maplist(arg(1), Bindings, Vars),
phrase(r_remove(Vars), Command),
r_eval($, Command, _).
r_remove(Vars) -->
"remove(", r_vars(Vars), ")".
r_vars([H|T]) -->
atom(H),
( {T==[]}
-> ""
; ",",
r_vars(T)
).
%! r_setup_console(+R)
%
% Set the notion of R's console with to the width of the Prolog
% console. This may be hooked by
% r_console_property(size(Rows,Cols) to deal with e.g., SWISH.
r_setup_console(R) :-
( r_console_property(size(_Rows, Cols))
-> true
; tty_size(_Rows, Cols)
), !,
format(string(Command), 'options(width=~d)', Cols),
r_eval(R, Command, _).
r_setup_console(_).
/*******************************
* QUASI QUOTATION *
*******************************/
:- quasi_quotation_syntax(r).
%% r(+Content, +Vars, +VarDict, -Goal) is det.
%
% Parse {|r(Arg,...||R-code|} into a the expression below. This
% expression may be passed to <-/2 and <-/1 as well as used
% directly as a goal, calling r_execute/3.
%
% r_execute(Assignments, Command, Result)
%
% @see https://cran.r-project.org/doc/manuals/r-release/R-lang.html#Parser
% @tbd Verify more of the R syntax.
r(Content, Vars, Dict, r_execute(Assignments, Command, _Result)) :-
include(qq_var(Vars), Dict, QQDict),
phrase_from_quasi_quotation(
r(QQDict, Assignments, Parts),
Content),
atomics_to_string(Parts, Command).
qq_var(Vars, _=Var) :-
member(V, Vars),
V == Var, !.
r(Dict, Assignments, [Pre|More]) -->
here(Here0),
r_tokens(_),
r_token(identifier(Name)),
here(Here1),
{ memberchk(Name=Var, Dict), !,
Assignments = [Name=Var|AT],
diff_to_atom(Here0, Here1, Pre)
},
r(Dict, AT, More).
r(_, [], [Last]) -->
string(Codes),
\+ [_], !,
{ atom_codes(Last, Codes) }.
%% diff_to_atom(+Start, +End, -Atom)
%
% True when Atom is an atom that represents the characters between
% Start and End, where End must be in the tail of the list Start.
diff_to_atom(Start, End, Atom) :-
diff_list(Start, End, List),
atom_codes(Atom, List).
diff_list(Start, End, List) :-
Start == End, !,
List = [].
diff_list([H|Start], End, [H|List]) :-
diff_list(Start, End, List).
here(Here, Here, Here).
/*******************************
* IMAGES *
*******************************/
:- multifile rserve:r_open_hook/2.
%% rserve:r_open_hook(+Name, -R)
%
% Called for lazy creation to the Rserve server. Connections are
% per-thread. The destination depends on settings:
%
% $ Unix domain socket :
% If `rserve:socket` is defined and not empty, it is taken
% as the path to a Unix domain socket to connect to.
% $ TCP/IP socket :
% Else, if `rserve:port` and `rserve:host` is defined, we
% connect to the indicated host and port.
%
% After the connection is established, the session can be
% configured using the hook r_init_session/1. The default calls
% r_setup_graphics/2 to setup graphics output to send SVG files.
rserve:r_open_hook($, R) :-
nb_current('R', R), !.
rserve:r_open_hook($, R) :-
setting(rserve:socket, Socket),
Socket \== '',
access_file(Socket, exist), !,
debug(r(connect), 'Connecting to ~p ...', [Socket]),
r_open(R,
[ host(Socket),
port(-1)
]),
r_setup(R).
rserve:r_open_hook($, R) :-
setting(rserve:port, Port),
setting(rserve:host, Host),
debug(r(connect), 'Connecting to ~p ...', [Host:Port]),
r_open(R,
[ host(Host),
port(Port)
]),
r_setup(R).
r_setup(R) :-
thread_at_exit(r_close(R)),
debug(r, 'Created ~p', [R]),
call_init_session(R),
nb_setval('R', R), !.
call_init_session(R) :-
r_init_session(R), !.
call_init_session(R) :-
r_setup_graphics(R, svg).
%% r_init_session(+RConn) is semidet.
%
% Multifile hook that is called after the Rserve server has handed
% us a new connection. If this hook fails, r_setup_graphics/2 is
% called to setup capturing graphics as SVG files.
%% r_setup_graphics(+Rconn, +Format) is det.
%
% Setup graphics output using files. Currently only supports
% `Format = svg`.
r_setup_graphics(R, svg) :-
r_eval(R, "mysvg <- function() {
svg(\"Rplot%03d.svg\")
par(mar=c(4,4,1,1))
}
options(device=mysvg)", X),
debug(r, 'Devices: ~p', [X]),
nb_setval('Rimage_base', 'Rplot'),
nb_setval('Rimage_ext', 'svg').
%% r_send_images is det.
%
% Collect the images saved on the server and send them to SWISH
% using pengine_output/1.
r_send_images :-
r_images(Images), !,
length(Images, Count),
debug(r, 'Got ~d images~n', [Count]),
r_send_images(Images).
r_send_images.
r_send_images(Images) :-
r_display_images(Images), !.
r_send_images(Images) :-
print_message(warning, r_images(Images)).
%% r_display_images(+Images:list)
%
% Hook to display images.
%
% @arg Images is a list of images. Each image is of the form
% Format(String), where Format is the file extension. Currently
% only uses `svg`. If not defined, print_message/2 is called
% with the term r_images(Images).
%% r_images(-Images:list) is semidet.
%
% Collect saved image files from Rserve. This assumes that
%
% 1. The R connection is in the global variable =R=. If
% there is no connection, there are no images.
% 2. There are only images if there is a current device.
% This is closed using =|dev.off()|=.
% 3. Images are called <base>%03d.<ext>, where <base> is
% in the global variable =Rimage_base= and <ext> in
% =Rimage_ext=.
r_images(List) :-
nb_current('R', _),
( r_eval($, "names(dev.list())", Devices),
Devices = ["svg"|_]
-> r_eval($, "dev.off()", _),
r_fetch_images(1, List)
).
r_fetch_images(I, Images) :-
nb_getval('Rimage_base', Base),
nb_getval('Rimage_ext', Ext),
format(string(Name), "~w~|~`0t~d~3+.~w", [Base,I,Ext]),
debug(r, 'Trying ~p~n', [Name]),
( catch(r_read_file($, Name, Content), E, r_error_fail(E))
-> debug(r, 'Got ~p~n', [Name]),
Image =.. [Ext,Content],
Images = [Image|Rest],
( debugging(r(plot))
-> save_plot(Name, Content)
; true
),
I2 is I+1,
r_fetch_images(I2, Rest)
; Images = []
).
r_error_fail(error(r_error(70),_)) :- !, fail.
r_error_fail(Error) :- print_message(warning, Error), fail.
save_plot(File, Data) :-
setup_call_cleanup(
open(File, write, Out, [type(binary)]),
format(Out, '~s', [Data]),
close(Out)).
/*******************************
* MESSAGES *
*******************************/
:- multifile
prolog:message//1.
prolog:message(r_images(Images)) -->
{ length(Images, Count) },
[ 'Rserve sent ~d images files.'-[Count], nl ],
[ 'Define r_call:r_display_images/1 to display them.'-[] ].