From 0deddd56035e9a290c4859444029814236c506b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Sat, 16 Oct 2010 14:54:48 +0100 Subject: [PATCH] include Nicos Angelopoulos r_session package. --- library/Makefile.in | 1 + library/r_session.yap | 1425 +++++++++++++++++++++++++++++++++++ library/r_session/r_demo.pl | 184 +++++ 3 files changed, 1610 insertions(+) create mode 100644 library/r_session.yap create mode 100644 library/r_session/r_demo.pl diff --git a/library/Makefile.in b/library/Makefile.in index b9ad5a340..32db506c2 100644 --- a/library/Makefile.in +++ b/library/Makefile.in @@ -56,6 +56,7 @@ PROGRAMS= \ $(srcdir)/prandom.yap \ $(srcdir)/queues.yap \ $(srcdir)/random.yap \ + $(srcdir)/r_session.yap \ $(srcdir)/rbtrees.yap \ $(srcdir)/readutil.yap \ $(srcdir)/regexp.yap \ diff --git a/library/r_session.yap b/library/r_session.yap new file mode 100644 index 000000000..963822494 --- /dev/null +++ b/library/r_session.yap @@ -0,0 +1,1425 @@ +:- module( r_session, + [ + r_open/0, r_open/1, + r_close/0, r_close/1, + r_in/1, r_in/2, + r_push/1, r_push/2, + r_out/2, r_out/3, + r_err/3, r_err/4, + r_print/1, r_print/2, + r_lines_print/1, r_lines_print/2, r_lines_print/3, + r_lib/1, r_lib/2, + r_flush/0, r_flush/1, + r_flush_onto/2, r_flush_onto/3, + current_r_session/1, current_r_session/3, + default_r_session/1, + r_session_data/3, r_streams_data/3, + r_history/0, r_history/1, r_history/2, + r_session_version/1, + r_bin/1, + r_bin_version/1, r_bin_version/2, + r_verbosity/1, + op( 950, xfx, (<-) ) + ] ). + +:- use_module( library(lists) ). +:- use_module( library(readutil) ). % read_line_to_codes/2. + +:- ( current_predicate(r_verbosity_level/1) -> true; + assert(r_verbosity_level(0)) ). + +:- dynamic( r_bin_location/1 ). +:- dynamic( r_session/3 ). +:- dynamic( r_session_history/2 ). +:- dynamic( r_old_bin_warning_issued/1 ). +:- dynamic( r_bin_takes_interactive/2 ). + +% Yap declaration: +:- ensure_loaded( library(system) ). % exec/3, file_exists/1, directory_files/2. +:- ensure_loaded( library(apply_macros) ). % maplist/3 +% end of Yap declaration. + +/** R session + +This library facilitates interaction with the R system for statistical +computing. It assumes an R executable in $PATH or can be given a location +to a functioning R executable (see r_bin/1 and r_open/1 for details on how +R is located). R is ran as a slave with Prolog writing on and reading from +the associated streams. Multiple sessions can be managed simultaneously. +Each has 3 main components: a name or alias, a term structure holding the +communicating streams and a number of associated data items. + +The library attempts to ease the translation between prolog terms and R +inputs. Thus, Prolog term =|x <- c(1,2,3)|= is translated to atomic =|'x +<- c(1,2,3)'|= which is then passed on to R. That is, =|<-|= is a +defined/recognised operator. =|X <- c(1,2,3)|=, where X is a variable, +instantiates X to the list =|[1,2,3]|=. Also 'Atom' <- [x1,...,xn] +translates to R code: Atom <- c(x1,...,xn). Currently only vectors can be +translated in this fashion. + +Although the library is primarily meant to be used as a research tool, +it still provides access to many functions of the R system that may render it +useful to a wider audience. The library provides access to R's plethora of vector and scalar +functions. We adicipate that of particular interest to Prolog programmers might be the fact +that the library can be used to create plots from Prolog objects. +Notably creating plots from lists of numbers. + +These capabilities are illustrated in the following example : + +== +rtest :- + r_open, + r_in( y <- rnorm(50) ), + r_print( y ), + r_in( x <- rnorm(y) ), + r_in( x11(width=5,height=3.5) ), + r_in( plot(x,y)), + write( 'Press Return to continue...' ), nl, + read_line_to_codes( user, _ ), + r_print( 'dev.off()' ), + r_in( Y <- y ), + write( y(Y) ), nl, + Z = [1,2,3,4,5,6,7,8,9], + r_in( z <- Z ), + r_print( z ), + r_close. +== + +@author Nicos Angelopoulos +@version 0:0:4 +@copyright Nicos Angelopoulos +@license YAP: Artistic +@see ensure_loaded(library('../doc/packages/examples/R/r_demo.pl')) +@see http://www.r-project.org/ +@author Windows-compatibility is based on work by `JAB' +*/ + +%%% Section: Interface predicates + + +%% r_bin( ?Rbin ) +% +% Register the default R location, +Rbin, or interrogate the current location: -Rbin. +% When interrogating Rbin is bound to the R binary that would be used by an r_open/0. +% The order of search is: registered location, environment variable 'R_BIN' and path defined. +% On unix systems path defined is the first R executable in $PATH. On MS wins it is the latest +% Rterm.exe found by expand_file_name( 'C:/Program Files/R/R-*/bin/Rterm.exe', Candidates ). +% The value Rbin == =retract= retracts the current registered location. +% Rbin == =test=, succeeds if an R location has been registered. +% +r_bin( Rbin ) :- + var( Rbin ), + !, + ( r_bin_location(Rbin) -> + true + ; + ( locate_rbin_file(Rbin) -> + M = 'There is no registered R executable. Using the one found by searching.', + r_verbose( M, 1 ) + ; + M = 'There is no registered or default R executatble. Use, r_bin(+Rbin).', + fail_term( M ) + ) + ). +r_bin( retract ) :- + !, + retractall( r_bin_location(_) ). +r_bin( test ) :- + !, + r_bin_location(_). +r_bin( Rbin ) :- + retractall( r_bin_location(_) ), + assert( r_bin_location(Rbin) ). + +%% r_open +% +% Open a new R session. Same as r_open( [] ). +% +r_open :- + r_open( [] ). + +%% r_open( +Opts ) +% +% Open a new R session with optional list of arguments. Opts should be +% a list of the following +% +% * alias(Alias) +% Name for the session. If absent or a variable an opaque term is +% generated. +% +% * assert(A) +% Assert token. By default session opened last is the default +% session (see default_r_session/1). Using A = =z= will push the +% session to the bottom of the pile. +% +% * at_r_halt(RHAction) +% R slaves used to halt when they encounter an error. +% This is no longer the case but this option is still present in case +% it is useful in the future. This option provides a handle to changing +% the behaviour of the session when a halt of the R-slave occurs. +% RHAction should be one of =abort=, =fail=, call/1, +% call_ground/1, =reinstate= or =restart=. Default is =fail=. When +% RHAction is =reinstate=, the history of the session is used to +% roll-back all the commands sent so far. At `restart' the session +% is restarted with same name and options, but history is not +% replayed. +% +% * copy(CopyTo,CopyWhat) +% Records interaction with R to a file/stream. CopyTo should be +% one of =null=, stream(Stream), OpenStream, AtomicFile, +% once(File) or many(File). In the case of many(File), file is +% opened and closed at each write operation. CopyWhat should be +% one of =both=, =in=, =out= or =none=. Default is no recording +% (CopyTo = =null=). +% +% * ssh(Host) +% * ssh(Host,Dir) +% Run R on Host with start directory Dir. Dir defaults to /tmp. +% Not supported on MS Windows. +% +% +% * rbin(Rbin) +% R executable location to use for this open operation. +% If the option is not present binary registered with r_bin/1 and +% environment variable R_BIN are examined for the full location of +% the R binary. In MS windows Rbin should point to Rterm.exe. Also see r_bin/1. +% +% * with(With) +% With is in [environ,restore,save]. The default behaviour is to +% start the R executable with flags =|--no-environ --no-restore +% --no-save|=. For each With value found in Opts the corresponding +% =|--no-|= flag is removed. +% +r_open( Opts ) :- + r_open_1( Opts, _R, false ). + +%% r_close +% +% Close the default R session. +% +r_close :- + ( default_r_session( Alias ) -> + r_close( Alias ) + ; + fail_term( no_default_open_r_session_could_be_found_to_close ) + ). + +%% r_close(+R) +% +% Close the named R session. +% +r_close( All ) :- + All == all, + !, + findall( Alias, ( retract( r_session(Alias,Streams,Data) ), + r_close_session( Alias, Streams, Data ) ), _AllAls ). + % write( closed_all(All) ), nl. +r_close( Alias ) :- + ( retract( r_session(Alias,Streams,Data) ) -> + r_close_session( Alias, Streams, Data ) + ; + fail_term( no_open_r_session_could_be_found_to_close_at:Alias ) + ). + +%% r_in(+Rcmd) +% +% Push Rcmd to the default R session. Output and Errors will be +% printed to the terminal. +% +r_in( This ) :- + default_r_session( R ), + r_in( R, This, _ ). + +%% r_in(+R,+Rcmd) +% +% As r_in/1 but for session R. +% +r_in( R, PrvThis ) :- + r_in( R, PrvThis, _ ). + +%% r_push(+Rcmd) +% +% As r_in/1 but does not consume error or output streams. +% +r_push( This ) :- + default_r_session( R ), + r_push( R, This ). + +%% r_push(+R,+Rcmd) +% +% As r_push/1 but for named session. +% +r_push( R, RCmd ) :- + current_r_session( R, Streams, Data ), + r_session_data( copy_to, Data, CopyTo ), + r_session_data( copy_this, Data, CopyThis ), + r_streams( input, Streams, Ri ), + r_input_normative( RCmd, RNrm ), + write( Ri, RNrm ), nl( Ri ), + r_record_term( CopyThis, CopyTo, RNrm ). + +%% r_out(+Rcmd,-Lines) +% +% Push Rcmd to default R session and grab output lines Lines as +% a list of code lists. +% +r_out( This, Read ) :- + default_r_session( R ), + r_out( R, This, Read ). + +%% r_out(+R,+Rcmd,-Lines) +% +% As r_out/2 but for named session R. +% +r_out( R, RCmd, RoLns ) :- + r_push( R, RCmd, Rplc, RoLns, ReLns, Halt, HCall ), + r_lines_print( ReLns, error, user_error ), + r_record_history( Halt, R, RCmd ), + r_out_halted_record( Halt, R, RoLns ), + replace_variables( Rplc ), + call( HCall ). + +%% r_err(+Rcmd,-Lines,-ErrLines) +% +% Push Rcmd to default R session and grab output lines Lines as +% a list of code lists. Error lines are in ErrLines. +% +r_err( This, Read, ErrRead ) :- + default_r_session( R ), + r_err( R, This, Read, ErrRead ). + +%% r_err(+R,+Rcmd,-Lines, -ErrLines) +% +% As r_err/3 but for named session R. +% +r_err( R, RCmd, RoLns, ReLns ) :- + r_push( R, RCmd, Rplc, RoLns, ReLns, Halt, HCall ), + r_lines_print( ReLns, error, user_error ), + r_record_history( Halt, R, RCmd ), + r_out_halted_record( Halt, R, RoLns ), + replace_variables( Rplc ), + call( HCall ). + +%% r_print(+X) +% +% A shortcut for r_in( print(X) ). +% +r_print( This ) :- + default_r_session( R ), + r_print( R, This ). + +%% r_print(+R,+X) +% +% As r_print/1 but for named session R. +% +r_print( R, This ) :- + r_out( R, This, Read ), + r_lines_print( Read, output ). + +%% r_lines_print( +Lines ) +% +% Print a list of code lists (Lines) to the user_output. +% Lines would normally be read of an R stream. +% +r_lines_print( Lines ) :- + r_lines_print( Lines, output, user_output ). + +%% r_lines_print( +Lines, +Type ) +% +% As r_lines_print/1 but Type declares whether to treat lines +% as output or error response. In the latter case they are written +% on user_error and prefixed with '!'. +% +r_lines_print( Lines, Type ) :- + r_lines_print_type_stream( Type, Stream ), + r_lines_print( Lines, Type, Stream ). + +%% r_lines_print( +Lines, +Type, +Stream ) +% +% As r_lines_print/3 but Lines are written on Stream. +% +r_lines_print( [], _Type, _Stream ). +r_lines_print( [H|T], Type, Stream ) :- + atom_codes( Atm, H ), + r_lines_print_prefix( Type, Stream ), + write( Stream, Atm ), nl( Stream ), + r_lines_print( T, Type, Stream ). + +%% r_lib(+L) +% +% A shortcut for r_in( library(X) ). +% +r_lib( Lib ) :- + default_r_session( R ), + r_lib( R, Lib ). + +%% r_lib(+R,+L) +% +% As r_lib/1 but for named session R. +% +r_lib( R, Lib ) :- + r_in( R, library(Lib) ). + +%% r_flush +% +% Flush default R's output and error on to the terminal. +% +r_flush :- + default_r_session( R ), + r_flush( R ). + +%% r_flush(+R) +% +% As r_flush/0 but for session R. +% +r_flush( R ) :- + r_flush_onto( R, [output,error], [Li,Le] ), + r_lines_print( Li, output ), + r_lines_print( Le, error ). + +%% r_flush_onto(+SAliases,-Onto) +% +% Flush stream aliases to code lists Onto. SAliases +% should be one of, or a list of, [output,error]. +% +r_flush_onto( RinStreamS, OntoS ) :- + default_r_session( R ), + r_flush_onto( R, RinStreamS, OntoS ). + +%% r_flush_onto(+R,+SAliases,-Onto) +% +% As r_flush_onto/2 for specified session R. +% +r_flush_onto( R, RinStreams, Ontos ) :- + ( is_list(RinStreams) -> RStreams = RinStreams; RStreams=[RinStreams] ), + % to_list( RinStreamS, RinStreams ), + r_input_streams_list( RStreams ), + r_flush_onto_1( RStreams, R, ROntos ), + ( is_list(RinStreams) -> Ontos = ROntos; Ontos=[ROntos] ). + +%% current_r_session(?R) +% True if R is the name of current R session. +% Can be used to enumerate all open sessions. +% +current_r_session( R ) :- + var( R ), + !, + r_session( R, _Session, _Data ). +current_r_session( R ) :- + r_session( R, _Session, _Data ), + !. +current_r_session( R ) :- + fail_term( 'Could not find session':R ). + +%% current_r_session(?R,?S,?D) +% +% True if R is an open session with streams S +% and data D (see introduction to the library). +% +current_r_session( Alias, R, Data ) :- + r_session( Alias, R, Data ). + +%% default_r_session(?R) +% +% True if R is the default session. +% +default_r_session( R ) :- + ( var(R) -> + ( r_session(R,_Cp1,_Wh1) -> + true + ; + fail_term( no_default_open_r_session_was_found ) + ) + ; + ( r_session(R,_Cp2,_Wh2) -> + true + ; + fail_term( no_open_r_session_at(R) ) + ) + ). + +%% r_streams_data(+SId,+Streams,-S) +% True if Streams is an R session streams +% structure and S is its stream corresponding +% to identifier SId, which should be one of +% [input,output,error]. +% +r_streams_data( input, r(Ri,_,_), Ri ). +r_streams_data( output, r(_,Ro,_), Ro ). +r_streams_data( error, r(_,_,Re), Re ). + +%% r_session_data(+DId,+Data,-Datum) +% +% True if Data is a structure representing +% R session associated data and Datum is its +% data item corresponding to data identifier +% DId. DId should be in +% [copy_to,copy_this,at_r_halt,opts]. +% +r_session_data( copy_to, rsdata(Copy,_,_,_), Copy ). +r_session_data( copy_this, rsdata(_,This,_,_), This ). +r_session_data( at_r_halt, rsdata(_,_,RHalt,_), RHalt ). +r_session_data( opts, rsdata(_,_,_,Opts), Opts ). + +%% r_history +% +% Print on user_output the history of the default session. +% +r_history :- + default_r_session( R ), + r_session_history( R, History ), + reverse( History, Hicory ), + write( history(R) ), nl, write('---' ), nl, + ( (member(H,Hicory),write(H),nl,fail) -> true; true ), + write( '---' ), nl. + +%% r_history(-H) +% +% H unifies to the history list of the Rcmds fed into the default +% session. Most recent command appears at the head of the list. +% +r_history( History ) :- + default_r_session( R ), + r_session_history( R, History ). + +%% r_history(?R,-H) +% As r_history/1 but for named session R. +% It can be used to enumerate all histories. +% It fails when no session is open. +% +r_history( R, History ) :- + r_session_history( R, History ). + +%% r_session_version(-Version) +% Installed version. Version is of the form Major:Minor:Fix, +% where all three are integers. +% +r_session_version( 0:0:4 ). + +%% r_verbose( What, CutOff ) +% +r_verbose( What, CutOff ) :- + r_verbosity_level( Level ), + ( CutOff > Level -> + true + ; + write( What ), nl + ). + +%% r_verbosity( ?Level ) +% +% Set, +Level, or interrogate, -Level, the verbosity level. +Level could be +% =false= (=0), =true= (=3) or an integer in {0,1,2,3}. 3 being the most verbose. +% The default is 0. -Level will instantiate to the current verbosity level, +% an integer in {0,1,2,3}. +% +r_verbosity( Level ) :- + var( Level ), + !, + r_verbosity_level( Level ). +r_verbosity( Level ) :- + ( Level == true -> + Numeric is 3 + ; + ( Level == false -> + Numeric is 0 + ; + ( integer(Level) -> + ( Level < 0 -> + write( 'Adjusting verbosity level to = 0. ' ), nl, + Numeric is 0 + ; + ( Level > 3 -> + write( 'Adjusting verbosity level to = 3. ' ), nl, + Numeric is 3 + ; + Numeric is Level + ) + ) + ; + fail_term( 'Unknown verbosity level. Use : true, false, 0-3' ) + ) + ) + ), + retractall( r_verbosity_level(_) ), + assert( r_verbosity_level(Numeric) ). + +%% r_bin_version( -Version) +% +% Get the version of R binary identified by r_bin/1. Version will have the +% same structure as in r_session_version/1 ie M:N:F. +% +r_bin_version( Version ) :- + r_bin( R ), + r_bin_version( R, Version ). + +%% r_bin_version( +Rbin, -Version ) +% +% Get the version of R binary identified by +Rbin. Version will have the +% same structure as in r_session_version/1 ie M:N:F. +% +r_bin_version( R, Version ) :- + r_bin_version_pl( R, Version ). + +%%% Section: Auxiliary predicates + +% Rcv == true iff r_open_1/3 is called from recovery. +% +r_open_1( Opts, Alias, Rcv ) :- + ( options_have_ssh(Opts,Host,Dir) -> + ( current_prolog_flag(windows,true) -> + fail_term( ssh_option_not_supported_on_ms_windows ) + ; + which( ssh, Ssh ) + ) + ; + true + ), + ( (memberchk(rbin(Rbin),Opts);locate_rbin(Ssh,Rbin)) -> + true + ; + fail_term( 'Use rbin/1 in r_open/n, or r_bin(\'Rbin\') or set R_BIN.' ) + ), + r_bin_arguments( Opts, Rbin, OptRArgs ), + % ( var(Harg) -> RArgs = OptRArgs; RArgs = [Host,Harg|OptRArgs] ), + ( var(Ssh) -> + Exec = Rbin, + Args = OptRArgs + ; + Exec = Ssh, + % atoms_concat( [' "cd ',Dir,'; ',Rbin,'"'], Harg ), + atoms_concat( ['cd ',Dir,'; '], Cd ), + PreArgs = [Cd,Rbin|OptRArgs], + double_quote_on_yap( PreArgs, TailArgs ), + Args = [Host|TailArgs] + % atoms_concat( ['ssh ', Host,' "cd ',Dir,'; ',RBin,'"'], R ) + ), + % atom_concat( PrvExec, RPsf, Exec ), + r_verbose( r_process( Exec, Args, Ri, Ro, Re ), 3 ), + r_process( Exec, Args, Ri, Ro, Re ), + RStreams = r(Ri,Ro,Re), + r_streams_set( Ri, Ro, Re ), + r_process_was_successful( Ri, Ro, Re ), + r_open_opt_copy( Opts, CpOn, CpWh, Rcv ), + r_open_opt_at_r_halt( Opts, RHalt ), + ( memberchk(alias(Alias),Opts) -> + ( var(Alias) -> + r_session_skolem( Alias, 1 ) + ; + ( r_session(Alias,_,_) -> + fail_term( 'Session already exists for alias':Alias ) + ; + true + ) + ) + ; + r_session_skolem( Alias, 1 ) + ), + RData = rsdata(CpOn,CpWh,RHalt,Opts), + ( memberchk(assert(Assert),Opts) -> + ( Assert == a -> + asserta( r_session(Alias,RStreams,RData) ) + ; + ( Assert == z -> + assertz( r_session(Alias,RStreams,RData) ) + ; + fail_term( 'Cannot decipher argument to assert/1 option':Assert ) + ) + ) + ; + asserta( r_session(Alias,RStreams,RData) ) + ), + AtRH = at_r_halt(reinstate), + ( (memberchk(history(false),Opts),\+memberchk(AtRH,Opts)) -> + true + ; + retractall( r_session_history(Alias,_) ), + assert( r_session_history(Alias,[]) ) + ). + +r_close_session( Alias, Streams, Data ) :- + r_streams_data( input, Streams, Ri ), + r_streams_data( output,Streams, Ro ), + r_streams_data( error, Streams, Re ), + r_session_data( copy_to, Data, CopyTo ), + r_session_data( copy_this, Data, CopyThis ), + write( Ri, 'q()' ), nl( Ri ), + r_record_term( CopyThis, CopyTo, 'q()' ), + ( (CopyTo=stream(CopyS),stream_property(CopyS,file_name(CopyF)),CopyF\==user)-> + close(CopyS) + ; + true + ), + close( Ri ), + close( Ro ), + close( Re ), + retractall( r_session_history(Alias,_) ). + +r_in( R, RCmd, Halt ) :- + r_push( R, RCmd, Rplc, RoLns, ReLns, Halt, HCall ), + r_out_halted_record( Halt, R, RoLns ), + r_lines_print( RoLns, output, user_output ), + r_lines_print( ReLns, error, user_error ), + r_record_history( Halt, R, RCmd ), + replace_variables( Rplc ), + call( HCall ). + +r_push( R, RCmd, Rplc, RoLns, ReLns, Halt, HCall ) :- + current_r_session( R, Streams, Data ), + r_session_data( copy_to, Data, CopyTo ), + r_session_data( copy_this, Data, CopyThis ), + r_streams( input, Streams, Ri ), + r_input_normative( RCmd, R, 0, RNrm, Rplc, _ ), + write( Ri, RNrm ), nl( Ri ), + r_record_term( CopyThis, CopyTo, RNrm ), + r_lines( Streams, error, ReLns ), + r_halted( ReLns, R, Halt, HCall ), + ( Halt == true -> + r_streams( output, Streams, Ro ), + r_read_lines( Ro, [], RoLns ) + ; + r_lines( Streams, output, RoLns ) + ), + r_record_lines( RoLns, output, CopyTo ), + r_record_lines( ReLns, error, CopyTo ), + ( (Halt==true,CopyTo=stream(Cl)) -> close(Cl); true ). + +r_out_halted_record( true, _Alias, [] ). +r_out_halted_record( false, _Alias, Lines ) :- + r_session_data( copy_this, Data, CopyThis ), + r_session_data( copy_to, Data, CopyTo ), + ( (CopyThis==out;CopyThis==both) -> + r_record_lines( Lines, output, CopyTo ) + ; + true + ). + +r_flush_onto_1( [], _R, [] ). +r_flush_onto_1( [H|T], R, [HOn|TOns] ) :- + current_r_session( R, Streams, _ ), + r_lines( Streams, H, HOn ), + r_flush_onto_1( T, R, TOns ). + +replace_variables( [] ). +replace_variables( [arp(R,Pv,Rv)|T] ) :- + r_out( R, Rv, Lines ), + r_read_list( Lines, Pv ), + % r_lines_to_pl_var( Lines, Pv ), + replace_variables( T ). + +% r_lines_to_pl_var( [], [] ). +% r_lines_to_pl_var( [H|T], [] ) :- + % r_line_to_pl_var( [H|T], [] ) :- + % r_lines_to_pl_var( T, TPv ). + +r_input_streams_list( Rins ) :- + ( select(output,Rins,NoInpIns) -> true; NoInpIns=Rins ), + ( select(error,NoInpIns,NoErrIns) -> true; NoErrIns=NoInpIns ), + ( NoErrIns = [] -> + true + ; + ( (memberchk(input,NoErrIns);memberchk(error,NoErrIns)) -> + fail_term( 'duplicate entries in input streams list':Rins ) + ; + fail_term( 'superfluous entries in input streams list':Rins ) + ) + ). + +% succeds if Rcmd produces empty output, otherwise it fails +ro_empty( R, Rcmd ) :- + r_out( R, Rcmd, [] ). + +r_input_normative( (A;B), R, I, This, Rplc, OutI ) :- + !, + r_input_normative( A, R, I, ThisA, RplcA, NxI ), + r_input_normative( B, R, NxI, ThisB, RplcB, OutI ), + atoms_concat( [ThisA,'; ',ThisB], This ), + append( RplcA, RplcB, Rplc ). + +% r_input_normative( Obj<-List, _R, I, This, Rplc, NxI ) :- + % % atomic( Obj ), + % is_list( List ), + % !, + % Rplc = [], + % NxI is I, + % pl_list_to_r_combine( List, + +r_input_normative( Obj<-Call, R, I, This, Rplc, NxI ) :- + !, + ( var(Obj) -> + Rplc = [arp(R,Obj,ThisObj)], + number_codes( I, ICs ), + append( "pl_Rv_", ICs, RvCs ), + atom_codes( ThisObj, RvCs ), + NxI is I + 1 + ; + Rplc = [], + r_input_normative( Obj, ThisObj ), + NxI is I + ), + r_input_normative( Call, ThisCall ), + atoms_concat( [ThisObj,' <- ',ThisCall], This ). +r_input_normative( PrvThis, _R, I, This, [], I ) :- + r_input_normative( PrvThis, This ). + +r_input_normative( Var, This ) :- + var(Var), + !, + This = Var. +r_input_normative( Opt=Val, This ) :- + !, + r_input_normative( Opt, ThisOpt ), + r_input_normative( Val, ThisVal ), + atoms_concat( [ThisOpt,'=',ThisVal], This ). +% 2008ac06, careful! we are changing behaviour here +r_input_normative( List, This ) :- + is_list( List ), + pl_list_to_r_combine( List, This ), + !. +r_input_normative( PrvThis, This ) :- + ( (\+ var(PrvThis),(PrvThis = [_|_];PrvThis=[])) -> + append( PrvThis, [0'"], ThisRight ), + atom_codes( This, [0'"|ThisRight] ) + ; + ( compound(PrvThis) -> + PrvThis =.. [Name|Args], + ( (current_op(_Pres,Asc,Name), + atom_codes(Asc,[_,0'f,_]), + Args = [Arg1,Arg2] + ) -> + r_input_normative( Arg1, Arg1Nrm ), + r_input_normative( Arg2, Arg2Nrm ), + atoms_concat( [Arg1Nrm,Name,Arg2Nrm], This ) + ; + r_input_normative_tuple( Args, Tuple ), + atoms_concat( [Name,'(',Tuple,')'], This ) + ) + ; + ( number(PrvThis) -> + number_codes( PrvThis, ThisCs ), + atom_codes( This, ThisCs ) + ; + This = PrvThis + ) + ) + ). + +r_input_normative_tuple( [], '' ). +r_input_normative_tuple( [H|T], Tuple ) :- + r_input_normative_tuple( T, Psf ), + r_input_normative( H, HNorm ), + ( Psf == '' -> Tuple = HNorm + ; atoms_concat([HNorm,',',Psf], Tuple) ). + +pl_list_to_r_combine( [H|T], This ) :- + number_atom_to_atom( H, Hatm ), + atom_concat( 'c(', Hatm, Pfx ), + pl_list_to_r_combine( T, Pfx, This ). + +pl_list_to_r_combine( [], Pfx, This ) :- + atom_concat( Pfx, ')', This ). +pl_list_to_r_combine( [H|T], Pfx, This ) :- + number_atom_to_atom( H, Hatm ), + atom_concat( Pfx, ',', PfxComma ), + atom_concat( PfxComma, Hatm, Nxt ), + pl_list_to_r_combine( T, Nxt, This ). + +number_atom_to_atom( NorA, Atom ) :- + number_atom_to_codes( NorA, Codes ), + atom_codes( Atom, Codes ). + +number_atom_to_codes( NorA, Codes ) :- + number( NorA ), + !, + number_codes( NorA, Codes ). +number_atom_to_codes( NorA, Codes ) :- + atom( NorA ), + !, + atom_codes( NorA, Codes ). + +r_read_lines( Ro, TermLine, Lines ) :- + read_line_to_codes( Ro, Line ), + r_read_lines_1( Line, TermLine, Ro, Lines ). + +r_halted( Lines, R, Halted, HCall ) :- + last( Lines, "Execution halted" ), + !, + Halted = true, + findall( rs(Alias,Streams,Data), retract(r_session(Alias,Streams,Data)), Sessions), + \+ var(R), + r_halted_recovery( Sessions, R, HCall ). +r_halted( _, _R, false, true ). + +r_halted_recovery( [], R, Which ) :- + ( var(Which) -> + fail_term( internal_error_in_recovering_from_halt(R) ) + ; + true + ). +r_halted_recovery( [rs(AliasH,StreamsH,DataH)|T], R, Which ) :- + ( R == AliasH -> + r_session_data( at_r_halt, DataH, AtHalt ), + r_halted_recovery_action( AtHalt, AliasH, StreamsH, DataH, Which ) + ; + assertz(r_session(AliasH,StreamsH,DataH)) + ), + r_halted_recovery( T, R, Which ). + +r_halted_recovery_action( restart, Alias, _Streams, Data, RecCall ) :- + Mess = 'at_r_halt(restart): restarting r_session ':Alias, + RecCall = (write( user_error, Mess ),nl( user_error )), + r_session_data( opts, Data, Opts ), + ( memberchk(copy(CopyTo,_),Opts) -> + r_halted_restart_copy(CopyTo) + ; + true + ), + r_open_1( Opts, Alias, true ), + current_r_session( Alias, Streams, _ ), + r_lines( Streams, output, _ReLines ). +r_halted_recovery_action( reinstate, Alias, _Streams, Data, RecCall ) :- + ( r_session_history(Alias,History) -> + r_session_data( opts, Data, Opts ), + r_open_1( Opts, Alias, true ), + reverse( History, Hicory ), + r_halted_recovery_rollback( Hicory, Alias ) + ; + fail_term( 'at_r_halt(reinstate): cannnot locate history for':Alias ) + ), + Mess = 'at_r_halt(reinstate): reinstating r_session ':Alias, + RecCall = (write( user_error, Mess ), nl( user_error ) ). +r_halted_recovery_action( abort, _Alias, _Streams, _Data, RecCall ) :- + Mess = 'at_r_halt(abort): R session halted by slave', + RecCall = (write( user_error, Mess ),nl( user_error ),abort). +r_halted_recovery_action( fail, Alias, _Streams, _Data, Call ) :- + retractall( r_session_history(Alias,_) ), + % % r_session_data( copy_to, Data, CopyTo ), + % write( copy_to(CopyTo) ), nl, + % ( CopyTo = stream(Stream) -> + % close(Stream) + % ; + % true + % ), + L='at_r_halt(fail): failure due to execution halted by slave on r_session', + Call = fail_term( L:Alias ). +r_halted_recovery_action( call(Call), _Alias, Streams, _Data, Call ) :- + Call = call( Call, Streams ). +r_halted_recovery_action( call_ground(Call), _Alias, _Streams, _Data, Call) :- + Call = call( Call ). + +r_halted_restart_copy( CopyTo ) :- + ((atomic(CopyTo),File=CopyTo);CopyTo=once(File)), + File \== user, % you never known + !, + open( File, read, Dummy ), + stream_property( Dummy, file_name(Full) ), + close( Dummy ), + ( stream_property(OpenStream,file_name(Full)) -> + write( close(OpenStream) ), nl, + close( OpenStream ) + ; + true + ). +r_halted_restart_copy( _CopyTo ). + +r_halted_recovery_rollback( [], _Alias ). +r_halted_recovery_rollback( [H|T], Alias ) :- + r_in( Alias, H, _Halted ), + r_halted_recovery_rollback( T, Alias ). + + +r_record_history( true, _Alias, _This ). +r_record_history( false, Alias, This ) :- + r_session_history( Alias, Old ), + !, + retractall( r_session_history(Alias,_) ), + assert( r_session_history(Alias,[This|Old]) ). +r_record_history( false, _, _ ). % fold with true if assumption is correct + +r_read_lines_1( eof, _TermLine, _Ro, Lines ) :- !, Lines = []. +r_read_lines_1( end_of_file, _TermLine, _Ro, Lines ) :- !, Lines = []. +r_read_lines_1( [255], _TermLine, _Ro, Lines ) :- !, Lines = []. + % yap idiosyncrasy +r_read_lines_1( TermLine, TermLine, _Ro, Lines ) :- !, Lines = []. +r_read_lines_1( Line, TermLine, Ro, [Line|Lines] ) :- + read_line_to_codes( Ro, NewLine ), + r_read_lines_1( NewLine, TermLine, Ro, Lines ). + +r_boolean( Boo, Rboo ) :- + ( memberchk(Boo,[t,true,'TRUE']) -> + Rboo = 'TRUE' + ; + memberchk(Boo,[f,false,'FALSE']), + Rboo = 'FALSE' + ). + +r_read_list( [], [] ). +r_read_list( [PreH|T], List ) :- + delete_leading( PreH, 0' , H ), + ( H = [0'[|Hrm] -> + break_list_on( Hrm, 0'], _, Hprv ), + delete_leading( Hprv, 0' , Hproper ) + ; + Hproper = H + ), + r_read_list_line( Hproper, List, ConTail ), + r_read_list( T, ConTail ). + +r_read_list_line( [], List, List ). +r_read_list_line( [0' |RRead], List, ConTail ) :- + !, + r_read_list_line( RRead, List, ConTail ). +r_read_list_line( [Fst|RRead], [H|List], ConTail ) :- + break_list_on( RRead, 0' , RemCs, RemNumCs ), + !, + number_codes( H, [Fst|RemCs] ), + r_read_list_line( RemNumCs, List, ConTail ). +r_read_list_line( [Fst|RemCs], [H|List], List ) :- + number_codes( H, [Fst|RemCs] ). + +r_streams( [], _R, [] ). +r_streams( [H|T], R, [SH|ST] ) :- + !, + r_stream( H, R, SH ), + r_streams( T, R, ST ). + +r_streams( Id, R, Stream ) :- + r_stream( Id, R, Stream ). + +r_stream( H, R, SH ) :- + % current_r_session( R ), + ( var(H) -> + fail_term( variable_stream_identifier ) + ; + true + ), + ( r_streams_data( H, R, SH ) -> + true + ; + fail_term( invalid_r_stream:H ) + ). + +/* +r_terminator( r(Ri,Ro,_Re), Lines ) :- + write( Ri, 'print(\"prolog_eoc\")' ), + nl( Ri ), + r_read_lines_till( Ro, "[1] \"prolog_eoc\"", Lines ). + +r_read_lines_till( Ro, Terminator, Lines ) :- + fget_line( Ro, Line ), + r_read_lines_till_1( Line, Terminator, Ro, Lines ). + +r_read_lines_till_1( Line, Line, _Ro, Lines ) :- + !, + Lines = []. +r_read_lines_till_1( Line, Terminator, Ro, [Line|Lines] ) :- + fget_line( Ro, NxLine ), + NxLine \== eof, + r_read_lines_till_1( NxLine, Terminator, Ro, Lines ). +*/ + +r_open_opt_copy( Opts, CpTerm, What, Rcv ) :- + ( (memberchk(copy(Cp,CpWh),Opts),Cp \== null) -> + % heere + ( ((catch(is_stream(Cp),_,fail),CpS=Cp);Cp=stream(CpS)) -> % catch = yap bug + CpTerm = stream(CpS) + ; + ( atomic(Cp) -> + ( Rcv==true -> Mode = append; Mode = write ), + open( Cp, Mode, CpStream ), + CpTerm = stream(CpStream) + ; + ( Cp = once(CpFile) -> + ( Rcv==true -> Mode = append; Mode = write ), + open( CpFile, Mode, CpStream ), + CpTerm = stream(CpStream) + ; + ( Cp = many(CpFile) -> + CpTerm = file(CpFile) + ; + fail_term( 'I cannot decipher 1st argument of copy/2 option':Cp ) + ) + ) + ) + ), + ( memberchk(CpWh,[both,none,in,out])-> + What = CpWh + ; + fail_term( 'I cannot decipher 2nd arg. to copy/2 option':CpWh ) + ) + ; + CpTerm = null, What = none + ). + +r_open_opt_at_r_halt( Opts, RHalt ) :- + ( memberchk(at_r_halt(RHalt),Opts) -> + Poss = [restart,reinstate,fail,abort,call(_),call_ground(_)], + ( memberchk(RHalt,Poss) -> + true + ; + fail_term( 'Cannot decipher argument to at_r_halt option':RHalt ) + ) + ; + RHalt = fail + ). + +r_bin_arguments( Opts, _Rbin, _RArgs ) :- + member( with(With), Opts ), + \+ memberchk(With, [environ,restore,save] ), + !, + fail_term( 'Cannot decipher argument to option with/1': With ). +r_bin_arguments( Opts, Rbin, Args ) :- + ( current_prolog_flag(windows,true) -> + Args = ['--ess','--slave'|RArgs] + ; % assuming unix here, --interactive is only supported on these + ( r_bin_takes_interactive(Rbin) -> + Args = ['--interactive','--slave'|RArgs] + ; + Args = ['--slave'|RArgs] + ) + ), + findall( W, member(with(W),Opts), Ws ), + sort( Ws, Sr ), + length( Ws, WsL ), + length( Sr, SrL ), + ( WsL =:= SrL -> + r_bin_arguments_complement( [environ,restore,save], Ws, RArgs ) + ; + fail_term( 'Multiple identical args in with/1 option': Ws ) + ). + +% r_opt_exec_no( [environ,restore,save], Ws, Pfx, Exec ) :- +r_opt_exec_no( [], _Ws, [] ). +r_opt_exec_no( [H|T], Ws, Exec ) :- + ( memberchk(H,Ws) -> + TExec=Exec + ; + atom_concat( '--no-', H, NoH ), + Exec=[NoH|TExec] + ), + r_opt_exec_no( T, Ws, TExec ). + +r_bin_arguments_complement( [], _Ws, [] ). +r_bin_arguments_complement( [H|T], Ws, Args ) :- + ( memberchk(H,Ws) -> + % we could add explicit --with- here ? + Args = TArgs + ; + atom_concat( '--no-', H, NoH ), + Args = [NoH|TArgs] + ), + r_bin_arguments_complement( T, Ws, TArgs ). + +r_record_lines( [], _Type, _CopyTo ) :- !. +r_record_lines( Lines, Type, CopyTo ) :- + ( CopyTo == null -> + true + ; + copy_stream_open( CopyTo, CopyStream ), + r_lines_print( Lines, Type, CopyStream ) + ). + +r_record_term( CopyThis, CopyTo, This ) :- + ( CopyThis == in; CopyThis == both), + CopyTo \== null, + !, + copy_stream_open( CopyTo, CopyOn ), + write( CopyOn, This ), + nl( CopyOn ), + copy_stream_close( CopyTo ). +r_record_term( _CopyThis, _CopyTo, _This ). + +copy_stream_open( stream(CopyStream), CopyStream ). +copy_stream_open( file(File), CopyStream ) :- + open( File, append, CopyStream ). + +copy_stream_close( Atom ) :- + atomic( Atom ), + !, + ( Atom == user -> + true + ; + close( Atom ) + ). +copy_stream_close( CopyTo ) :- + copy_stream_close_non_atomic( CopyTo ). + +copy_stream_close_non_atomic( file(CopyTo) ) :- close( CopyTo ). +copy_stream_close_non_atomic( once(CopyTo) ) :- close( CopyTo ). +copy_stream_close_non_atomic( many(CopyTo) ) :- close( CopyTo ). +copy_stream_close_non_atomic( stream(_) ). + +/* +write_list_to_comma_separated( [], _Sep, _Out ). +write_list_to_comma_separated( [H|T], Sep, Out ) :- + write( Out, Sep ), + write( Out, H ), + write_list_to_comma_separated( T, ',', Out ). + */ + +fail_term( Term ) :- + ( Term = What:Which -> + write( user_error, What ), + write( user_error, ': ' ), + write( user_error, Which ) + ; + write( user_error, Term ) + ), + nl( user_error ), fail. + +r_lines( Streams, ROstream, Lines ) :- + r_streams_data( input, Streams, Ri ), + r_streams_data( ROstream, Streams, Ro ), + ( ROstream == error -> + Mess = 'message("prolog_eoc")', + Trmn = "prolog_eoc" + ; + Mess = 'print("prolog_eoc")', + Trmn = "[1] \"prolog_eoc\"" + ), + Excp = error(io_error(write, _), context(_,_)), + catch( (write(Ri,Mess),nl(Ri)), Excp, true ), + r_read_lines( Ro, Trmn, Lines ). + +r_lines_print_type_stream( output, user_output ). +r_lines_print_type_stream( error, user_error ). + +r_lines_print_prefix( error, Stream ) :- write( Stream, '! ' ). +r_lines_print_prefix( output, _Stream ). + +r_session_skolem( Alias, I ) :- + Alias = '$rsalias'(I), + \+ r_session( Alias, _, _ ), + !. +r_session_skolem( Alias, I ) :- + NxI is I + 1, + r_session_skolem( Alias, NxI ). + +r_process_was_successful( Ri, Ro, Re ) :- + Mess = 'message("prolog_eoc")', + Trmn = "prolog_eoc", + catch( (write(Ri,Mess),nl(Ri)), Excp, true ), + r_read_lines( Re, Trmn, Lines ), + r_lines_print( Lines, error, user_error ), + ( (var(Excp),Lines==[]) -> + true + ; + ( Excp = error(io_error(write, _), context(_,_)) -> + true + ; + print_message( error, Excp ) + ), + close( Ri ), close( Ro ), close( Re ), + fail_term( failed_to_open_session ) + ). + +%%%%%%%% +% break_list_on( +List, +Element, ?LeftPartition, ?RightPartition ). +% Element does not appear in either the end of LeftPartition, +% or as first element of RightPartition. +% Only finds first partition so Element should be ground +% | ?- break_list_on( L, El, [a], [c,b,d,b,e] ). +% = [a,El,c,b,d,b,e] ? ; no +% +break_list_on( [X|Xs], X, [], Xs ) :- + !. +break_list_on( [X|Xs], Xa, [X|XLa], XRa ) :- + break_list_on( Xs, Xa, XLa, XRa ). + +delete_leading( [], _Chop, [] ). +delete_leading( [H|T], Chop, Clean ) :- + ( H == Chop -> + R = T, + Clean = TClean + ; + R = [], + Clean = [H|T] + ), + delete_leading( R, Chop, TClean ). + +options_have_ssh( Opts, Host, Dir ) :- + ( memberchk(ssh(Host),Opts) -> + Dir = '/tmp' + ; + memberchk( ssh(Host,Dir), Opts ) + ). + +locate_rbin( Ssh, RBin ) :- + locate_rbin_file( File ), + ( var(Ssh) -> + ( + current_prolog_flag(windows,true) + -> + Exe='exe', + file_name_extension( File, Exe, RBin ) + ; + File = RBin + ) + -> + exists_file( RBin ) + ; + % currently when we using ssh, there is no check for existance + % of the binary on the remote host + File = RBin + ), + r_verbose( using_R_bin(RBin), 1 ). + +% order of clauses matters. only first existing one to succeed is considered. +locate_rbin_file( RBin ) :- + % current_predicate( r_bin/1 ), + r_bin_location( RBin ). +locate_rbin_file( RBin ) :- + environ( 'R_BIN', RBin ). +locate_rbin_file( RBin ) :- + current_prolog_flag( unix, true ), + which( 'R', RBin ). +locate_rbin_file( RBin ) :- + current_prolog_flag( windows, true ), + r_bin_wins( RBin ). + +r_bin_wins( Rbin ) :- + r_expand_wins_rterm( Stem, Candidates ), + r_verbose( wins_candidates(Candidates), 3 ), + Candidates \== [], + ( Candidates = [Rbin] -> + true + ; + maplist( atom_concat(Stem), Tails, Candidates ), + maplist( atom_codes, Tails, TailsCs ), + cur_tail_candidates_with_pair( TailsCs, Candidates, Pairs ), + keysort( Pairs, Sorted ), + reverse( Sorted, [_-Rbin|_] ) + ), + !. + +cur_tail_candidates_with_pair( [], [], [] ). +cur_tail_candidates_with_pair( [H|T], [F|R], [Hnum-F|TPairs] ) :- + ( break_list_on( H, 0'/, Hlft, _ ) -> true; break_list_on( H, 0'\\, Hlft, _) ), + break_list_on( Hlft, 0'., MjCs, NonMjCs ), + break_list_on( NonMjCs, 0'., MnCs, FxCs ), + maplist( number_codes, Nums, [MjCs,MnCs,FxCs] ), + integers_list_to_integer( Nums, 2, 1000, 0, Hnum ), + cur_tail_candidates_with_pair( T, R, TPairs ). + +integers_list_to_integer( [], _Pow, _Spc, Int, Int ). +integers_list_to_integer( [H|T], Pow, Spc, Acc, Int ) :- + Nxt is Acc + ( H * (Spc ** Pow) ), + Red is Pow - 1, + integers_list_to_integer( T, Red, Spc, Nxt, Int ). + +r_bin_warning :- + write('Flag --interactive which is used when starting R sessions,'), + nl, + write( 'is not behaving as expected on your installed R binary.' ), nl, + write( 'R sessions with this binary will be started without this flag.' ), + nl, + write( 'As a result, graphic windows will suffer and the connection is' ), + write( ' more flaky.' ), nl, + write( 'If you want to overcome these limitations we strongly suggest' ), + nl, + write( 'the installation of R from sources.' ), nl, nl. + +r_bin_takes_interactive( Rbin ) :- + r_bin_takes_interactive( Rbin, Bool ), + !, + Bool == true. +r_bin_takes_interactive( Rbin ) :- + Args = ['--interactive','--slave','--no-environ','--no-restore','--no-save'], + r_process( Rbin, Args, Ri, Ro, Re ), + r_streams_set( Ri, Ro, Re ), + % Streams = r(Ri,Ro,Re), + write( Ri, 'print("whatever")' ), nl( Ri ), + % r_read_lines( Re, eof, RoLns ), + % read_line_to_codes( Re, _ReLns ), + % r_lines( Streams, error, ReLns ), + % r_lines( Streams, output, RoLns ), + read_line_to_codes( Ro, RoLn ), + ( append("print", _, RoLn ) -> + r_bin_warning, + Bool = false + ; + Bool = true + ), + assert( r_bin_takes_interactive(Rbin,Bool) ), + write( Ri, 'q()' ), nl( Ri ), + read_line_to_codes( Re, _ReLn ), + % write( Ri, 'message("whatever")' ), nl( Ri ), + close( Ri ), close( Ro ), close( Re ), + Bool == true. + +% Section: Yap Specifics. + +atoms_concat( Atoms, Concat ) :- + atom_concat( Atoms, Concat ). + +which( Which, This ) :- + SshStrs = [null,pipe(SshWhc),null], + atom_concat( 'which ', Which, ProcWhich ), + exec( ProcWhich, SshStrs, _ ), + read_line_to_codes( SshWhc, Codes), + atom_codes( This, Codes ), + r_verbose( which(Which,This), 2 ). + +r_streams_set( _Ri, _Ro, _Re ). + +r_process( Exec, Args, Ri, Ro, Re ) :- + space_out_by_atom( Args, SpcArgs ), + atoms_concat( [Exec,' '|SpcArgs], Full ), + Streams = [pipe(Ri),pipe(Ro),pipe(Re)], + r_verbose( creating(Full,Streams), 3 ), + exec( Full, Streams, _ ). + +r_bin_version_pl( R, Mj:Mn:Fx ) :- + Streams = [std,pipe(Ro),std], + atom_concat( R, ' --version', Rv ), + exec( Rv, Streams, _ ), + % read_line_to_codes( Ro, _ ), + read_line_to_codes( Ro, Codes ), + break_list_on( Codes, 0' , _R, Psf1 ), + break_list_on( Psf1, 0' , _V, Psf2 ), + break_list_on( Psf2, 0' , VersionCs, _ ), + break_list_on( VersionCs, 0'., MjCs, VPsf1Cs ), + break_list_on( VPsf1Cs, 0'., MnCs, FxCs ), + number_codes( Mj, MjCs ), + number_codes( Mn, MnCs ), + number_codes( Fx, FxCs ). + +space_out_by_atom( [], [] ). +space_out_by_atom( [A|T], R ) :- + ( T == [] -> + R = [A|M] + ; + R = [A,' '|M] + ), + space_out_by_atom( T, M ). + +% r_bin_wins( _ ) :- + % r_expand_wins_rterm( _ ). + % fail. % I don't know how to do this in Yap... + +r_expand_wins_rterm( WinsStem, Candidates ) :- + PfsR = 'C:/Program Files/R/', + % WinsStem = 'C:\\Program Files\\R\\R-', % yap 5-1-3 + WinsStem = 'C:/Program Files/R/R-', % yap 6-0-3 + file_exists( PfsR ), % works for dirs as well in Yap + directory_files( PfsR, Files ), + Psf = '/bin/Rterm.exe', + sieve_r_term_containers( Files, PfsR, Psf, Candidates ). + +sieve_r_term_containers( [], _Pfx, _Psf, [] ). +sieve_r_term_containers( [H|T], Pfx, Psf, Cs ) :- + atom_concat( H, Psf, HPsf ), + atom_concat( Pfx, HPsf, C ), + ( file_exists(C) -> + Cs = [C|TCs] + ; + Cs = TCs + ), + sieve_r_term_containers( T, Pfx, Psf, TCs ). + + +exists_file( File ) :- + file_exists( File ). + +double_quote_on_yap( InArgs, Args ) :- + append( ['"'|InArgs], ['"'], Args ). diff --git a/library/r_session/r_demo.pl b/library/r_session/r_demo.pl new file mode 100644 index 000000000..c4431fdd3 --- /dev/null +++ b/library/r_session/r_demo.pl @@ -0,0 +1,184 @@ + +:- use_module(library(lists)). % member/2. +:- use_module(library(readutil)). % read_line_to_codes/2. + +:- nl, nl. +:- ( r_bin(Rbin) -> + write( 'Will be using the R found at: ' ), nl, + write( Rbin ), nl, nl + ; + write( 'This session cannot locate an R executable. Please register the location' ), nl, + write( 'of the R executalbe using r_bin/1 before you can run the demos.' ), nl, nl + ). + +:- write( 'Demo predicates for R (r_session) package.' ), nl. +:- write( 'See r_demo_1/0,...,r_demo_10/0.' ), nl. +:- write( 'The goal r_demo/0 is a shorthand for r_demo_1/0,...,r_demo_7/0 which are the main demos.' ), nl, nl. +:- write( 'r_demo_all/0 and r_demo_clauses/0 for r_demo_1,...,r_demo_10.' ), nl. +:- write( 'which include demos for some non-basic features.' ), nl. +:- write( 'You need to look at the sources before running r_demo_8,9 and 10.' ). +:- nl, nl. + +r_demo :- + nl, nl, + Rdemos = [r_demo_1,r_demo_2,r_demo_3,r_demo_4,r_demo_5,r_demo_6,r_demo_7], + r_demo( Rdemos, false ). + +r_demo_all:- + nl, nl, + Rdemos = [r_demo_1,r_demo_2,r_demo_3,r_demo_4,r_demo_5,r_demo_6,r_demo_7,r_demo_8,r_demo_9,r_demo_10], + r_demo( Rdemos, false ). + +r_demo_clauses :- + nl, nl, + Rdemos = [r_demo_1,r_demo_2,r_demo_3,r_demo_4,r_demo_5,r_demo_6,r_demo_7,r_demo_8,r_demo_9,r_demo_10], + r_demo( Rdemos, true ). + +r_demo( Rdemos, Clauses ) :- + member(Wh, Rdemos ), + write( doing-Wh ), nl, + ( Clauses == true -> + write( 'Clauses: ' ), nl, + findall( Wh-Body, (clause(Wh,Body), + portray_clause((Wh:-Body)), nl), _ ) + ; + true + ), + ( call(Wh) -> + true + ; + write( 'Demo ended with failure.' ), nl + ), + nl, nl, + fail. +r_demo( _Rdemos, _ ) :- + write( done ), nl. + +r_demo_1 :- + write( 'Demo: basic vector interactions.' ), nl, nl, + r_open, + r_in( x <- c(10.4, 5.6, 3.1, 6.4, 21.7) ), + ( r_out( print(x), Lines ), r_lines_print( Lines ), fail; true ), + r_print( x ), + r_in( x ), + r_in( (y <- c(6,5,4,3,2,1); y) ), % The extra paranthesis are only + % needed for Yap. + r_in( Z <- c(10.4, 5.6, 3.1, 6.4, 21.7) ), + write( z(Z) ), nl, + r_close. + +r_demo_2 :- + write( 'Demo: plots (screen and postscript).' ), nl, nl, + r_open, + r_in( y <- rnorm(50) ), + r_print( y ), + r_in( Y <- y ), + write( y(Y) ), nl, + r_in( x <- rnorm(y) ), + r_print( x ), + r_in( X <- x ), + write( x(X) ), nl, + r_in( x11(width=5,height=3.5) ), + r_in( plot(x,y)), + write( 'Press Return to continue...' ), nl, + current_prolog_flag( version, V ), + ( integer(V) -> User = current_input % SWI Prolog + ; User = user ), + read_line_to_codes( User, _ ), + r_in( 'dev.off()' ), + r_in( 'postscript(file="x_vs_y.eps")' ), + r_in( plot(x,y)), + r_in( 'dev.off()' ), + r_close, + !, % Swi leaves a backtracking point at read_line_to_codes/2 + write( 'Check that file x_vs_y.eps has been created.' ), nl. + +r_demo_3 :- + write( 'Demo: aliases.' ), nl, nl, + r_open( [alias(mamonaku)] ), + ( current_r_session(Alias),write(session(Alias)),nl, fail; true ), + r_in( mamonaku, x <- c(10.4, 5.6, 3.1, 6.4, 21.7) ), + r_print( mamonaku, x ), + r_close( mamonaku ). + +r_demo_4 :- + write( 'Demo: history.' ), nl, nl, + r_open, + ( r_history(A,B), write(history(A,B)), nl, fail; true ), + r_in( x <- c(10.4, 5.6, 3.1, 6.4, 21.7) ), + ( r_out( print(x), Lines ), r_lines_print( Lines ), fail; true ), + r_print( x ), + ( r_history(C,D), write(h(C,D)), nl, fail; true ), + r_close. + +r_demo_5 :- + write( 'Demo: calls to R functions.' ), nl, nl, + r_open, + r_in( i <- 0:14 ), + r_print( i ), + r_in( I <- i ), + write( 'I'(I) ), nl, + r_in( x <- i/10 ), + r_in( y <- c(176.547,194.2552,218.5462,441.3706,795.786,1190.8606,1321.0128,1326.4694,1437.3068,1364.6906,1343.768,1513.7298,1553.8264,1554.1748,1549.399) ), + r_print( (integrate(splinefun(x,y), 0.2, 0.4)) ), + r_close. + +r_demo_6 :- + write( 'Demo: copying output and error on to file.' ), nl, nl, + r_open( [copy('rec_both.txt',both)] ), + r_in( x <- c(10.4, 5.6, 3.1, 6.4, 21.7) ), + r_print( x ), + write( 'Check that file rec_both.txt has been created.' ), nl, + r_close. + +r_demo_7 :- + write( 'Demo: error on R.' ), nl, nl, + r_open( [at_r_halt(restart)] ), + r_in( x <- c(10.4, 5.6, 3.1, 6.4, 21.7) ), + r_print( x ), + r_print( y ), + r_print( x ), + r_close. + +%%% Cut-off + +r_demo_8 :- + write( 'Demo: reinstate on halt.' ), nl, + write( 'This is no longer valid.' ), nl, nl, + r_open( [at_r_halt(reinstate)] ), + r_in( x <- c(10.4, 5.6, 3.1, 6.4, 21.7) ), + r_print( y ), + % here slave dies + % and r_session tries to restar_demo it and replay all commands. + r_print( x ), + % succeeds + r_close. + +/* change 192.168.0.* to a host in your domain before running the following. */ +r_demo_9 :- + write( 'Demo: ssh on a machine with R on a different location.' ), nl, nl, + r_open( [ssh('192.168.0.3')] ), + r_in( I <- 0:14 ), + write( 'I'(I) ), nl, + r_close. + +r_demo_10 :- + write( 'Demo: ssh on a machine with explicit set of the remote R location.' ), + nl, nl, + r_bin( '/usr/local/users/nicos/local/bin/R' ), + r_open( [ssh('192.168.0.3')] ), + r_in( I <- 0:14 ), + write( 'I'(I) ), nl, + r_close. + +/* +% You can replace any of the above r_open/0,1, with one of the following +r_open( [with(restore)] ). + % do not use --no-restore on the R flags +r_open( [copy(copied,both)] ). + % copy both input and output to file copied +r_open( [at_r_halt(restar_demo),alias(mamunaku),copy(copied_in,in)] ). + % copy input to file copied_in +r_open( [at_r_halt(restar_demo),alias(mamunaku),copy(copy_out,out)] ). + % copy output to file copied_out + */