1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2016-2019, VU University Amsterdam
    7			      CWI, Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module(r_call,
   37	  [ (<-)/2,			% ?Var, +Expression
   38	    (<-)/1,			% +Expression
   39	    r_call/2,			% +Function, +Options
   40
   41					% Internal predicates
   42	    r/4,			% Quasi quotation parser
   43	    r_execute/3,		% +Assignments, +Command, -Result
   44	    r_setup_graphics/2,		% +Rconn, +Format
   45
   46	    op(900,  fx, <-),
   47	    op(900, xfx, <-),
   48	    op(400, yfx, $),
   49	    op(100, yf,  [])
   50	  ]).   51:- use_module(r_serve).   52:- use_module(r_grammar).   53:- use_module(r_term).   54:- use_module(library(apply)).   55:- use_module(library(error)).   56:- use_module(library(lists)).   57:- use_module(library(debug)).   58:- use_module(library(quasi_quotations)).   59:- use_module(library(dcg/basics)).   60:- use_module(library(settings)).   61:- use_module(library(option)).   62
   63:- multifile
   64	r_init_session/1,		% +Session
   65	r_console/2,			% +Type, ?Term
   66	r_console_property/1,		% ?Property
   67	r_display_images/1.		% +Images

?- numlist(1,10,Data),
   {|r(Data)||plot(Data)|}.

  105:- setting(rserve:socket, atom, '/home/rserve/socket',
  106	   "Unix domain socket for connecting to Rserve").  107:- setting(rserve:host,	atom, '127.0.0.1',
  108	   "Host for connecting to Rserve").  109:- setting(rserve:port,	integer, 6311,
  110	   "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.

  117Var <- Expression :-
  118	var(Var), !,
  119	(   var(Expression)
  120	->  instantiation_error(Expression)
  121	;   Expression = r_execute(Assignments, Command, Var)
  122	->  r_execute(Assignments, Command, Var)
  123	;   phrase(r_expression(Expression, Assignments), Command)
  124	->  r_execute(Assignments, Command, Var)
  125	;   domain_error(r_expression, Expression)
  126	).
  127Var <- Expression :-
  128	(   atom(Var),
  129	    r_primitive_data(Expression)
  130	->  r_assign($, Var, Expression)
  131	;   <-(Var<-Expression)
  132	).
  133
  134r_primitive_data(Data) :-
  135	is_list(Data), !.
  136r_primitive_data(Data) :-
  137	compound(Data), !, fail.

 <-(Expression) is det

Evaluate Expression, discarding the result. Possible console output is captured using the R function capture.output.

  144<- Term :-
  145	(   var(Term)
  146	->  instantiation_error(Term)
  147	;   Term = r_execute(Assignments, Command, _Var)
  148	->  r_capture_output(Assignments, Command)
  149	;   phrase(r_expression(Term, Assignments), Command)
  150	->  r_capture_output(Assignments, Command)
  151	;   domain_error(r_expression, Term)
  152	).

 r_capture(Assignments, Command)

Execute Command, presenting the R console output to the (Prolog) user.

  159r_capture_output(Assignments, Command) :-
  160	to_string(Command, CommandS),
  161	r_assign($, 'Rserve.cmd', CommandS),
  162	r_execute(Assignments,
  163		  "capture.output(eval(parse(text=Rserve.cmd)))",
  164		  Output),
  165	emit_r_output(Output).
  166
  167to_string(Command, CommandS) :-
  168	string(Command), !,
  169	CommandS = Command.
  170to_string(Command, CommandS) :-
  171	string_codes(CommandS, Command).
  172
  173emit_r_output(Output) :-
  174	r_console(stdout, Output), !.
  175emit_r_output(Output) :-
  176	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

Compatibility

- This is a partial implementation of the corresponding real predicate.

  194r_call(Func, Options) :-
  195	partition(eq_pair, Options, XArgs, Options1),
  196	extend(Func, XArgs, Call),
  197	option(fcall(Call), Options1, _),
  198	(   option(call(true), Options1, true)
  199	->  (   option(rvar(Var), Options1)
  200	    ->  Var <- Call
  201	    ;   <- Call
  202	    )
  203	;   true
  204	).
  205
  206eq_pair(_=_).
  207
  208extend(Compound, XArgs, Term) :-
  209	compound(Compound), !,
  210	compound_name_arguments(Compound, Func, Args0),
  211	append(Args0, XArgs, Args),
  212	compound_name_arguments(Term, Func, Args).
  213extend(Atom, XArgs, Term) :-
  214	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.

Arguments:

Assignments	- is a list of Name=Value, where Name must be a valid R indentifier.
Command	- is a string holding the R command to execute

  234r_execute(Assignments, Command, Result) :-
  235	r_setup_console($),
  236	setup_call_cleanup(
  237	    maplist(r_bind, Assignments),
  238	    r_eval_ex($, Command, Result),
  239	    r_unbind(Assignments)),
  240	r_send_images.
  241
  242r_bind(RVar=Value) :-
  243	r_assign($, RVar, Value).

 r_unbind(+Bindings)

Remove the created bindings from the R environment

  249r_unbind([]) :- !.
  250r_unbind(Bindings) :-
  251	maplist(arg(1), Bindings, Vars),
  252	phrase(r_remove(Vars), Command),
  253	r_eval($, Command, _).
  254
  255r_remove(Vars) -->
  256	"remove(", r_vars(Vars), ")".
  257
  258r_vars([H|T]) -->
  259	atom(H),
  260	(   {T==[]}
  261	->  ""
  262	;   ",",
  263	    r_vars(T)
  264	).

 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.

  272r_setup_console(R) :-
  273	(   r_console_property(size(_Rows, Cols))
  274	->  true
  275	;   tty_size(_Rows, Cols)
  276	), !,
  277	format(string(Command), 'options(width=~d)', Cols),
  278	r_eval(R, Command, _).
  279r_setup_console(_).
  280
  281
  282		 /*******************************
  283		 *	  QUASI QUOTATION	*
  284		 *******************************/
  285
  286:- 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 also

- https://cran.r-project.org/doc/manuals/r-release/R-lang.html#Parser

To be done

- Verify more of the R syntax.

  299r(Content, Vars, Dict, r_execute(Assignments, Command, _Result)) :-
  300	include(qq_var(Vars), Dict, QQDict),
  301	phrase_from_quasi_quotation(
  302	    r(QQDict, Assignments, Parts),
  303	    Content),
  304	atomics_to_string(Parts, Command).
  305
  306qq_var(Vars, _=Var) :-
  307	member(V, Vars),
  308	V == Var, !.
  309
  310r(Dict, Assignments, [Pre|More]) -->
  311	here(Here0),
  312	r_tokens(_),
  313	r_token(identifier(Name)),
  314	here(Here1),
  315	{ memberchk(Name=Var, Dict), !,
  316	  Assignments = [Name=Var|AT],
  317	  diff_to_atom(Here0, Here1, Pre)
  318	},
  319	r(Dict, AT, More).
  320r(_, [], [Last]) -->
  321	string(Codes),
  322	\+ [_], !,
  323	{ 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.

  331diff_to_atom(Start, End, Atom) :-
  332	diff_list(Start, End, List),
  333	atom_codes(Atom, List).
  334
  335diff_list(Start, End, List) :-
  336	Start == End, !,
  337	List = [].
  338diff_list([H|Start], End, [H|List]) :-
  339	diff_list(Start, End, List).
  340
  341here(Here, Here, Here).
  342
  343
  344		 /*******************************
  345		 *	       IMAGES		*
  346		 *******************************/
  347
  348:- 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.

  366rserve:r_open_hook($, R) :-
  367	nb_current('R', R), !.
  368rserve:r_open_hook($, R) :-
  369	setting(rserve:socket, Socket),
  370	Socket \== '',
  371	access_file(Socket, exist), !,
  372	debug(r(connect), 'Connecting to ~p ...', [Socket]),
  373	r_open(R,
  374	       [ host(Socket),
  375		 port(-1)
  376	       ]),
  377	r_setup(R).
  378rserve:r_open_hook($, R) :-
  379	setting(rserve:port, Port),
  380	setting(rserve:host, Host),
  381	debug(r(connect), 'Connecting to ~p ...', [Host:Port]),
  382	r_open(R,
  383	       [ host(Host),
  384		 port(Port)
  385	       ]),
  386	r_setup(R).
  387
  388r_setup(R) :-
  389	thread_at_exit(r_close(R)),
  390	debug(r, 'Created ~p', [R]),
  391	call_init_session(R),
  392	nb_setval('R', R), !.
  393
  394call_init_session(R) :-
  395	r_init_session(R), !.
  396call_init_session(R) :-
  397	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.

  410r_setup_graphics(R, svg) :-
  411	r_eval(R, "mysvg <- function() {
  412                     svg(\"Rplot%03d.svg\")
  413		     par(mar=c(4,4,1,1))
  414                   }
  415	           options(device=mysvg)", X),
  416	debug(r, 'Devices: ~p', [X]),
  417	nb_setval('Rimage_base', 'Rplot'),
  418	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.

  425r_send_images :-
  426	r_images(Images), !,
  427	length(Images, Count),
  428	debug(r, 'Got ~d images~n', [Count]),
  429	r_send_images(Images).
  430r_send_images.
  431
  432r_send_images(Images) :-
  433	r_display_images(Images), !.
  434r_send_images(Images) :-
  435	print_message(warning, r_images(Images)).

 r_display_images(+Images:list)

Hook to display images.

Arguments:

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.

  458r_images(List) :-
  459	nb_current('R', _),
  460	(   r_eval($, "names(dev.list())", Devices),
  461	    Devices = ["svg"|_]
  462	->  r_eval($, "dev.off()", _),
  463	    r_fetch_images(1, List)
  464	).
  465
  466r_fetch_images(I, Images) :-
  467	nb_getval('Rimage_base', Base),
  468	nb_getval('Rimage_ext', Ext),
  469	format(string(Name), "~w~|~`0t~d~3+.~w", [Base,I,Ext]),
  470	debug(r, 'Trying ~p~n', [Name]),
  471	(   catch(r_read_file($, Name, Content), E, r_error_fail(E))
  472	->  debug(r, 'Got ~p~n', [Name]),
  473	    Image =.. [Ext,Content],
  474	    Images = [Image|Rest],
  475	    (   debugging(r(plot))
  476	    ->  save_plot(Name, Content)
  477	    ;	true
  478	    ),
  479	    I2 is I+1,
  480	    r_fetch_images(I2, Rest)
  481	;   Images = []
  482	).
  483
  484r_error_fail(error(r_error(70),_)) :- !, fail.
  485r_error_fail(Error) :- print_message(warning, Error), fail.
  486
  487save_plot(File, Data) :-
  488	setup_call_cleanup(
  489	    open(File, write, Out, [type(binary)]),
  490	    format(Out, '~s', [Data]),
  491	    close(Out)).
  492
  493
  494		 /*******************************
  495		 *	      MESSAGES		*
  496		 *******************************/
  497
  498:- multifile
  499	prolog:message//1.  500
  501prolog:message(r_images(Images)) -->
  502	{ length(Images, Count) },
  503	[ 'Rserve sent ~d images files.'-[Count], nl ],
  504	[ 'Define r_call:r_display_images/1 to display them.'-[] ]