diff --git a/RProvider.sln b/RProvider.sln index b4de8f35..6b6481d2 100644 --- a/RProvider.sln +++ b/RProvider.sln @@ -39,6 +39,7 @@ Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "content", "content", "{33FD docs\content\plugins.md = docs\content\plugins.md docs\content\reading-rdata.fsx = docs\content\reading-rdata.fsx docs\content\Statistics-QuickStart.fsx = docs\content\Statistics-QuickStart.fsx + docs\content\tutorial-RemoteR.fsx = docs\content\tutorial-RemoteR.fsx docs\content\tutorial.fsx = docs\content\tutorial.fsx docs\content\whatwhy.md = docs\content\whatwhy.md EndProjectSection diff --git a/docs/content/tutorial-RemoteR.fsx b/docs/content/tutorial-RemoteR.fsx new file mode 100644 index 00000000..b994b56b --- /dev/null +++ b/docs/content/tutorial-RemoteR.fsx @@ -0,0 +1,113 @@ +(*** hide ***) +// Include the right directories so that the documentation tool tips work +#nowarn "211" // Ignore warning that a search path does not exist on #I +#I "../../packages/FSharp.Data.1.1.10/lib/net40/" +#I "../../bin/" + +(** +# RemoteR Provider Tutorial + +## Referencing the provider + +In order to use the RemoteR provider, you need to reference the `RDotNet.dll` library +(which is a .NET connector for R) and the `RProvider.dll` itself. For this tutorial, +we use `open` to reference a number of packages including `stats`, `tseries` and `zoo`: +*) +#I "../packages/RProvider.1.0.3/lib" +#r "RDotNet.dll" +#r "RDotNet.FSharp.dll" +#r "RDotNet.NativeLibrary.dll" +#r "RProvider.dll" +#r "RProvider.Runtime.dll" + +open RDotNet +open RProvider + +open System +open System.Net + +type RRSession = RemoteR<"localhost", 8888, false> +let RR = new RRSession() + +(** +If either of the namespaces above are unrecognized, you need to install the package in R +using `install.packages("stats")`. + +## Obtaining data + +In this tutorial, we use [F# Data](http://fsharp.github.io/FSharp.Data/) to access stock +prices from the Yahoo Finance portal. For more information, see the documentation for the +[CSV type provider](http://fsharp.github.io/FSharp.Data/library/CsvProvider.html). + +The following snippet uses the CSV type provider to generate a type `Stocks` that can be +used for parsing CSV data from Yahoo. Then it defines a function `getStockPrices` that returns +array with prices for the specified stock and a specified number of days: +*) +#r "FSharp.Data.dll" +open FSharp.Data + +type Stocks = CsvProvider<"http://ichart.finance.yahoo.com/table.csv?s=SPX"> + +/// Returns prices of a given stock for a specified number +/// of days (starting from the most recent) +let getStockPrices stock count = + let url = "http://ichart.finance.yahoo.com/table.csv?s=" + [| for r in Stocks.Load(url + stock).Take(count).Data -> float r.Open |] + |> Array.rev + +/// Get opening prices for MSFT for the last 255 days +let msftOpens = getStockPrices "MSFT" 255 + +(** +## Calling R functions + +Now, we're ready to call R functions using the type provider. The following snippet takes +`msftOpens`, calculates logarithm of the values using `R.log` and then calculates the +differences of the resulting vector using `R.diff`: +*) + +// Retrieve stock price time series and compute returns +let msft = msftOpens |> RR.``base``.log |> RR.``base``.diff + + +(** +If you want to see the resulting values, you can call `msft.AsVector()` in F# Interactive. +Next, we use the `acf` function to display the atuo-correlation and call `adf_test` to +see if the `msft` returns are stationary/non-unit root: +*) + +let a = RR.stats.acf(msft) +let adf = RR.tseries.adf_test(msft) + +(** +After running the first snippet, a window similar to the following should appear (note that +it might not appear as a top-most window). + +
+ +
+ +Finally, we can obtain data for multiple different indicators and use the `R.pairs` function +to produce a matrix of scatter plots: +*) + +// Build a list of tickers and get diff of logs of prices for each one +let tickers = + [ "MSFT"; "AAPL"; "X"; "VXX"; "SPX"; "GLD" ] +let data = + [ for t in tickers -> + printfn "got one!" + t, getStockPrices t 255 |> RR.``base``.log |> RR.``base``.diff ] + +// Create an R data frame with the data and call 'R.pairs' +let df = RR.``base``.data_frame(namedParams data) +RR.graphics.pairs(df) + +(** +As a result, you should see a window showing results similar to these: + +
+ +
+ +*) diff --git a/src/RProvider/RInterop.fs b/src/RProvider/RInterop.fs index 53384728..2f50f9cc 100644 --- a/src/RProvider/RInterop.fs +++ b/src/RProvider/RInterop.fs @@ -312,6 +312,9 @@ module RDotNetExtensions = /// [omit] module RInterop = + type StringLiteral(value:string) = + member this.value = value + type RValue = | Function of RParameter list * HasVarArgs | Value @@ -342,26 +345,38 @@ module RInterop = printfn "Ignoring name %s of type %s" name something RValue.Value - let getPackages() : string[] = + let getPackages_ (eval: string -> SymbolicExpression) : string[] = eval(".packages(all.available=T)").GetValue() - let getPackageDescription packageName: string = + let getPackages() : string[] = + getPackages_ eval + + let getPackageDescription_ (eval: string -> SymbolicExpression) packageName : string = eval("packageDescription(\"" + packageName + "\")$Description").GetValue() + + let getPackageDescription packageName: string = + getPackageDescription_ eval packageName - let getFunctionDescriptions packageName : Map = + let getFunctionDescriptions_ (exec: string -> unit) (eval: string -> SymbolicExpression) packageName : Map = exec <| sprintf """rds = readRDS(system.file("Meta", "Rd.rds", package = "%s"))""" packageName Map.ofArray <| Array.zip ((eval "rds$Name").GetValue()) ((eval "rds$Title").GetValue()) + let getFunctionDescriptions packageName : Map = + getFunctionDescriptions_ exec eval packageName + let private packages = System.Collections.Generic.HashSet() - let loadPackage packageName : unit = + let loadPackage_ (eval: string -> SymbolicExpression) (packages: System.Collections.Generic.HashSet) packageName : unit = if not(packages.Contains packageName) then if not(eval("require(" + packageName + ")").GetValue()) then failwithf "Loading package %s failed" packageName packages.Add packageName |> ignore + let loadPackage packageName : unit = + loadPackage_ eval packages packageName + [] - let internal getBindingsDefn = """function (pkgName) { + let getBindingsDefn = """function (pkgName) { require(pkgName, character.only=TRUE) pkgListing <- ls(paste("package:",pkgName,sep="")) lapply( @@ -377,11 +392,15 @@ module RInterop = } ) }""" + + let getBindingsFromR_ evalTo eval = + let symbolName = getNextSymbolName() + evalTo (getBindingsDefn.Replace("\r","")) symbolName + fun packageName -> eval (sprintf "%s('%s')" symbolName packageName) + let internal getBindingsFromR = lazy - let symbolName = getNextSymbolName() - evalTo (getBindingsDefn.Replace("\r", "")) symbolName - fun (packageName) -> eval (sprintf "%s('%s')" symbolName packageName) + getBindingsFromR_ evalTo eval let internal bindingInfoFromR (bindingEntry: GenericVector) = let entryList = bindingEntry.AsList() @@ -411,51 +430,59 @@ module RInterop = RValue.Value name, value - let getBindings packageName : Map = + let getBindings_ (getBindingsFromR: string -> SymbolicExpression) packageName : Map = // TODO: Maybe get these from the environments? - let bindings = getBindingsFromR.Value packageName + let bindings = getBindingsFromR packageName [| for entry in bindings.AsList() -> entry.AsList() |] |> Array.map (fun (entry: GenericVector) -> bindingInfoFromR entry) |> Map.ofSeq - let callFunc (packageName: string) (funcName: string) (argsByName: seq>) (varArgs: obj[]) : SymbolicExpression = - // We make sure we keep a reference to any temporary symbols until after exec is called, - // so that the binding is kept alive in R - // TODO: We need to figure out how to unset the symvol - let tempSymbols = System.Collections.Generic.List() - let passArg (arg: obj) : string = - match arg with - | :? Missing -> failwithf "Cannot pass Missing value" - | :? int | :? double -> arg.ToString() - // This doesn't handle escaping so we fall through to using toR - //| :? string as sval -> "\"" + sval + "\"" - | :? bool as bval -> if bval then "TRUE" else "FALSE" - // We allow pairs to be passed, to specify parameter name - | _ when arg.GetType().IsConstructedGenericType && arg.GetType().GetGenericTypeDefinition() = typedefof<_*_> - -> match FSharpValue.GetTupleFields(arg) with - | [| name; value |] when name.GetType() = typeof -> - let name = name :?> string - tempSymbols.Add(name, engine.Value.SetValue(value, name)) - name - | _ -> failwithf "Pairs must be string * value" - | _ -> let sym,se = toR arg - tempSymbols.Add(sym, se) - sym + let getBindings packageName : Map = + getBindings_ getBindingsFromR.Value packageName + + // Generic implementation of callFunc so that the function can be reused for differing symbol return types + let callFunc_<'TExpr> (eval: string -> 'TExpr) (packageName: string) (funcName: string) (argsByName: seq>) (varArgs: obj[]) : 'TExpr = + // We make sure we keep a reference to any temporary symbols until after exec is called, + // so that the binding is kept alive in R + // TODO: We need to figure out how to unset the symvol + let tempSymbols = System.Collections.Generic.List() + let passArg (arg: obj) : string = + match arg with + | :? Missing -> failwithf "Cannot pass Missing value" + | :? int | :? double -> arg.ToString() + // This doesn't handle escaping so we fall through to using toR + //| :? string as sval -> "\"" + sval + "\"" + | :? StringLiteral as sval -> sval.value + | :? bool as bval -> if bval then "TRUE" else "FALSE" + // We allow pairs to be passed, to specify parameter name + | _ when arg.GetType().IsConstructedGenericType && arg.GetType().GetGenericTypeDefinition() = typedefof<_*_> + -> match FSharpValue.GetTupleFields(arg) with + | [| name; value |] when name.GetType() = typeof -> + let name = name :?> string + tempSymbols.Add(name, engine.Value.SetValue(value, name)) + name + | _ -> failwithf "Pairs must be string * value" + | _ -> let sym,se = toR arg + tempSymbols.Add(sym, se) + sym - let argList = [| - // Pass the named arguments as name=val pairs - for kvp in argsByName do - if not(kvp.Value = null || kvp.Value :? Missing) then - yield kvp.Key + "=" + passArg kvp.Value - - // Now yield any varargs - if varArgs <> null then - for argVal in varArgs -> - passArg argVal - |] - - let expr = sprintf "%s::`%s`(%s)" packageName funcName (String.Join(", ", argList)) - eval expr + let argList = [| + // Pass the named arguments as name=val pairs + for kvp in argsByName do + if not(kvp.Value = null || kvp.Value :? Missing) then + yield kvp.Key + "=" + passArg kvp.Value + + // Now yield any varargs + if varArgs <> null then + for argVal in varArgs -> + passArg argVal + |] + + let expr = sprintf "%s::`%s`(%s)" packageName funcName (String.Join(", ", argList)) + eval expr + + let callFunc (packageName: string) (funcName: string) (argsByName: seq>) (varArgs: obj[]) : SymbolicExpression = + callFunc_ eval packageName funcName argsByName varArgs /// Turn an `RValue` (which captures type information of a value or function) /// into a serialized string that can be spliced in a quotation @@ -472,8 +499,9 @@ module RInterop = else let hasVar = match serialized.[0] with '1' -> true | '0' -> false | _ -> invalidArg "serialized" "Should start with a flag" RValue.Function(List.ofSeq (serialized.Substring(1).Split(';')), hasVar) - - let call (packageName: string) (funcName: string) (serializedRVal:string) (namedArgs: obj[]) (varArgs: obj[]) : SymbolicExpression = + + // Generic implementation of call so that the function can be reused for differing symbol return types + let call_<'TExpr> (eval: string -> 'TExpr) (packageName: string) (funcName: string) (serializedRVal: string) (namedArgs: obj[]) (varArgs: obj[]) : 'TExpr = //loadPackage packageName match deserializeRValue serializedRVal with @@ -486,11 +514,14 @@ module RInterop = failwithf "Function %s expects %d named arguments and you supplied %d" funcName namedArgCount namedArgs.Length *) let argsByName = seq { for n,v in Seq.zip argNames namedArgs -> KeyValuePair(n, v) } - callFunc packageName funcName argsByName varArgs + callFunc_ eval packageName funcName argsByName varArgs | RValue.Value -> let expr = sprintf "%s::%s" packageName funcName eval expr + + let call (packageName: string) (funcName: string) (serializedRVal:string) (namedArgs: obj[]) (varArgs: obj[]) : SymbolicExpression = + call_ eval packageName funcName serializedRVal namedArgs varArgs /// Convert a value to a value in R. /// Generally you shouldn't use this function - it is mainly for testing. @@ -530,4 +561,4 @@ type REnv(fileName:string) = /// (This is equivalent to calling `R.ls` function) member x.Keys = let ls = RInterop.callFunc "base" "ls" (namedParams ["envir", box env]) [||] - ls.GetValue() \ No newline at end of file + ls.GetValue() diff --git a/src/RProvider/RInteropClient.fs b/src/RProvider/RInteropClient.fs index 0400be6a..b96f2267 100644 --- a/src/RProvider/RInteropClient.fs +++ b/src/RProvider/RInteropClient.fs @@ -59,4 +59,15 @@ module internal RInteropClient = let withServer f = lock serverlock <| fun () -> let server = GetServer() - f server \ No newline at end of file + f server + + let mutable localServerInstance = None + let withLocalServer f = + lock serverlock <| fun () -> + let server = match localServerInstance with + | Some s -> s + | _ -> + let s = new RInteropServer() + localServerInstance <- Some s + s + f server diff --git a/src/RProvider/RInteropServer.fs b/src/RProvider/RInteropServer.fs index 9f43c974..a8c4a112 100644 --- a/src/RProvider/RInteropServer.fs +++ b/src/RProvider/RInteropServer.fs @@ -21,27 +21,55 @@ type RInteropServer() = | ex -> failwith ex.Message + let mutable remoteSessions = Map.empty + member x.RInitValue = match initResultValue with | RInit.RInitError error -> Some error | _ -> None + member private x.GetRemoteSession(config:SessionConfig) = + let sessionKey = (config.hostName, config.port, config.blocking) + if not (remoteSessions.ContainsKey sessionKey) then + remoteSessions <- remoteSessions.Add(sessionKey, RemoteSession.GetConnection(config)) + remoteSessions.[sessionKey] + member x.GetPackages() = exceptionSafe <| fun () -> getPackages() + member x.GetPackages(remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteSession(remoteSession).getPackages() + member x.LoadPackage(package) = exceptionSafe <| fun () -> loadPackage package + + member x.LoadPackage(package, remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteSession(remoteSession).loadPackage package + member x.GetBindings(package, remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteSession(remoteSession).getBindings package + member x.GetBindings(package) = exceptionSafe <| fun () -> getBindings package + member x.GetFunctionDescriptions(package:string, remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteSession(remoteSession).getFunctionDescriptions package + member x.GetFunctionDescriptions(package:string) = exceptionSafe <| fun () -> getFunctionDescriptions package + member x.GetPackageDescription(package, remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteSession(remoteSession).getPackageDescription package + member x.GetPackageDescription(package) = exceptionSafe <| fun () -> getPackageDescription package diff --git a/src/RProvider/RProvider.DesignTime.fsproj b/src/RProvider/RProvider.DesignTime.fsproj index 31c56acb..b6d4d4b7 100644 --- a/src/RProvider/RProvider.DesignTime.fsproj +++ b/src/RProvider/RProvider.DesignTime.fsproj @@ -59,7 +59,11 @@ + + + + diff --git a/src/RProvider/RProvider.Runtime.fsproj b/src/RProvider/RProvider.Runtime.fsproj index 5721ad99..32509a89 100644 --- a/src/RProvider/RProvider.Runtime.fsproj +++ b/src/RProvider/RProvider.Runtime.fsproj @@ -62,6 +62,8 @@ + + diff --git a/src/RProvider/RProvider.fs b/src/RProvider/RProvider.fs index 0df99ef2..8afcf6e4 100644 --- a/src/RProvider/RProvider.fs +++ b/src/RProvider/RProvider.fs @@ -9,6 +9,7 @@ open RProvider open RProvider.Internal.Configuration open RProvider.Internal +// Type provider for the R type (Local R session) [] type public RProvider(cfg:TypeProviderConfig) as this = inherit TypeProviderForNamespaces() diff --git a/src/RProvider/RProviderRemote.fs b/src/RProvider/RProviderRemote.fs new file mode 100644 index 00000000..3deb1238 --- /dev/null +++ b/src/RProvider/RProviderRemote.fs @@ -0,0 +1,127 @@ +namespace RProvider.Remote + +open System +open System.IO +open System.Reflection +open Samples.FSharp.ProvidedTypes +open Microsoft.FSharp.Core.CompilerServices +open RProvider +open RProvider.Internal.Configuration +open RProvider.Internal + +// Type provider for the parameterized RemoteR type (Remote R session proxied through svSocket in local R session) +[] +type public RProviderRemote(cfg:TypeProviderConfig) as this = + inherit TypeProviderForNamespaces() + + let useReflectionOnly = true + + let runtimeAssembly = + if useReflectionOnly then Assembly.ReflectionOnlyLoadFrom cfg.RuntimeAssembly + else Assembly.LoadFrom cfg.RuntimeAssembly + + let ns = "RProvider.Remote" + let baseType = typeof + let staticParams = + [ ProvidedStaticParameter("host", typeof) + ProvidedStaticParameter("port", typeof) + ProvidedStaticParameter("blocking", typeof) + ] + + let remoteRType = ProvidedTypeDefinition(runtimeAssembly, ns, "RemoteR", Some baseType) + + do remoteRType.DefineStaticParameters( + parameters=staticParams, + instantiationFunction=(fun typeName parameterValues -> + let host = parameterValues.[0] :?> string + let port = parameterValues.[1] :?> int + let blocking = parameterValues.[2] :?> bool + let remoteConfig = new SessionConfig(host, port, blocking) + let sessionType = + ProvidedTypeDefinition( + runtimeAssembly, + ns, + typeName, + baseType = Some baseType + ) + sessionType.AddXmlDoc <| sprintf + "A strongly typed interface to the R session hosted at %s, port %d through svSocket" + remoteConfig.hostName + remoteConfig.port + RemoteRTypeBuilder.generateTypes remoteConfig sessionType + + let ctor = + ProvidedConstructor( + parameters = [], + InvokeCode = fun args -> <@@ RemoteSession.GetConnection(host, port, blocking) :> obj @@> + ) + ctor.AddXmlDoc "Initialize a connected R session hosted through svSocket." + sessionType.AddMember ctor + + let sessionEvalToHandle = + ProvidedMethod( + methodName = "evalToHandle", + parameters = [ ProvidedParameter("expr", typeof) ], + returnType = typeof, + InvokeCode = fun args -> if args.Length <> 2 then + failwithf "Expected 2 argument and received %d" args.Length + <@@ ((%%args.[0]:obj) :?> RemoteSession).evalToHandle %%args.[1] @@> + ) + sessionType.AddMember sessionEvalToHandle + + let sessionEvalToSymbolicExpression = + ProvidedMethod( + methodName = "eval", + parameters = [ ProvidedParameter("expr", typeof) ], + returnType = typeof, + InvokeCode = fun args -> if args.Length <> 2 then + failwithf "Expected 2 argument and received %d" args.Length + <@@ ((%%args.[0]:obj) :?> RemoteSession).evalToSymbolicExpression %%args.[1] @@> + ) + sessionType.AddMember sessionEvalToSymbolicExpression + + let sessionAssign = + ProvidedMethod( + methodName = "assign", + parameters = [ ProvidedParameter("name", typeof); ProvidedParameter("value", typeof) ], + returnType = typeof, + InvokeCode = fun args -> if args.Length <> 3 then + failwithf "Expected 3 argument and received %d" args.Length + <@@ ((%%args.[0]:obj) :?> RemoteSession).assign %%args.[1] %%args.[2] @@> + ) + sessionType.AddMember sessionAssign + + let sessionGet = + ProvidedMethod( + methodName = "get", + parameters = [ ProvidedParameter("name", typeof) ], + returnType = typeof, + InvokeCode = fun args -> if args.Length <> 2 then + failwithf "Expected 2 argument and received %d" args.Length + <@@ ((%%args.[0]:obj) :?> RemoteSession).getRemoteSymbol %%args.[1] @@> + ) + sessionType.AddMember sessionGet + + let sessionFinalize = + ProvidedMethod( + methodName = "Finalize", + parameters = [], + returnType = typeof, + InvokeCode = fun args -> <@@ ((%%args.[0]:obj) :?> RemoteSession).close() @@> + ) + sessionType.DefineMethodOverride(sessionFinalize, sessionType.GetMethod "Finalize") + + let sessionRemoteSessionProperty = + ProvidedProperty( + propertyName = "_interopSession", + propertyType = typeof, + GetterCode = fun args -> <@@ (%%args.[0]:obj) :?> RemoteSession @@> + ) + sessionType.AddMember sessionRemoteSessionProperty + + sessionType + )) + + do this.AddNamespace(ns, [remoteRType]) + + diff --git a/src/RProvider/RRProvider.fs b/src/RProvider/RRProvider.fs new file mode 100644 index 00000000..a7e53e12 --- /dev/null +++ b/src/RProvider/RRProvider.fs @@ -0,0 +1,39 @@ +namespace RProvider + +open System +open System.IO +open System.Reflection +open Samples.FSharp.ProvidedTypes +open Microsoft.FSharp.Core.CompilerServices +open RProvider +open RProvider.Internal.Configuration +open RProvider.Internal + +// Type provider for the RR type (Remote R session proxied through svSocket in local R session) +[] +type public RRProvider(cfg:TypeProviderConfig) as this = + inherit TypeProviderForNamespaces() + + let useReflectionOnly = true + + let runtimeAssembly = + if useReflectionOnly then Assembly.ReflectionOnlyLoadFrom cfg.RuntimeAssembly + else Assembly.LoadFrom cfg.RuntimeAssembly + + static do + // When RProvider is installed via NuGet, the RDotNet assembly and plugins + // will appear typically in "../../*/lib/net40". To support this, we look at + // RProvider.dll.config which has this pattern in custom key "ProbingLocations". + // Here, we resolve assemblies by looking into the specified search paths. + AppDomain.CurrentDomain.add_AssemblyResolve(fun source args -> + resolveReferencedAssembly args.Name) + + // Generate all the types and log potential errors + let buildTypes () = + try + for ns, types in RRTypeBuilder.initAndGenerate(runtimeAssembly) do + this.AddNamespace(ns, types) + with e -> + Logging.logf "RProvider constructor failed: %O" e + reraise() + do buildTypes () diff --git a/src/RProvider/RRTypeBuilder.fs b/src/RProvider/RRTypeBuilder.fs new file mode 100644 index 00000000..551b295c --- /dev/null +++ b/src/RProvider/RRTypeBuilder.fs @@ -0,0 +1,125 @@ +namespace RProvider + + +open System +open System.Collections.Generic +open System.Reflection +open System.IO +open System.Diagnostics +open System.Threading +open Samples.FSharp.ProvidedTypes +open Microsoft.FSharp.Core.CompilerServices +open RProvider +open RProvider.Internal +open RInterop +open RInteropInternal +open RInteropClient +open Microsoft.Win32 +open System.IO + +module internal RRTypeBuilder = + + let generateTypes ns asm = + withServer <| fun server -> + seq { + // Expose all available packages as namespaces + Logging.logf "generateTypes: getting packages" + for package in server.GetPackages() do + let pns = ns + "." + package + let pty = ProvidedTypeDefinition(asm, pns, "RR", Some(typeof)) + + // Note use of withServer - this helps ensure we'll try to recovery from a crashed session + pty.AddXmlDocDelayed <| fun () -> withServer <| fun serverDelayed -> serverDelayed.GetPackageDescription package + pty.AddMembersDelayed( fun () -> + withServer <| fun serverDelayed -> + [ serverDelayed.LoadPackage package + let bindings = serverDelayed.GetBindings package + + // We get the function descriptions for R the first time they are needed + let titles = lazy withServer (fun s -> s.GetFunctionDescriptions package) + + for name, rval in Map.toSeq bindings do + let memberName = makeSafeName name + + // Serialize RValue to a string, so that we can include it in the + // compiled quotation (and do not have to get the info again at runtime) + let serializedRVal = RInterop.serializeRValue rval + + match rval with + | RValue.Function(paramList, hasVarArgs) -> + let paramList = [ for p in paramList -> + ProvidedParameter(makeSafeName p, typeof, optionalValue=null) + + if hasVarArgs then + yield ProvidedParameter("paramArray", typeof, optionalValue=null, isParamArray=true) + ] + + let paramCount = paramList.Length + + let pm = ProvidedMethod( + methodName = memberName, + parameters = paramList, + returnType = typeof, + IsStaticMethod = true, + InvokeCode = fun args -> if args.Length <> paramCount then + failwithf "Expected %d arguments and received %d" paramCount args.Length + if hasVarArgs then + let namedArgs = + Array.sub (Array.ofList args) 0 (paramCount-1) + |> List.ofArray + let namedArgs = Quotations.Expr.NewArray(typeof, namedArgs) + let varArgs = args.[paramCount-1] + <@@ RRSession.CurrentSession().call package name serializedRVal %%namedArgs %%varArgs @@> + else + let namedArgs = Quotations.Expr.NewArray(typeof, args) + <@@ RRSession.CurrentSession().call package name serializedRVal %%namedArgs [||] @@> ) + + pm.AddXmlDocDelayed (fun () -> match titles.Value.TryFind name with + | Some docs -> docs + | None -> "No documentation available") + + yield pm :> MemberInfo + + // Yield an additional overload that takes a Dictionary + // This variant is more flexible for constructing lists, data frames etc. + let pdm = ProvidedMethod( + methodName = memberName, + parameters = [ ProvidedParameter("paramsByName", typeof>) ], + returnType = typeof, + IsStaticMethod = true, + InvokeCode = fun args -> if args.Length <> 1 then + failwithf "Expected 1 argument and received %d" args.Length + let argsByName = args.[0] + <@@ let vals = %%argsByName: IDictionary + let valSeq = vals :> seq> + RRSession.CurrentSession().callFunc package name valSeq null @@> ) + yield pdm :> MemberInfo + | RValue.Value -> + yield ProvidedProperty( + propertyName = memberName, + propertyType = typeof, + IsStatic = true, + GetterCode = fun _ -> <@@ RRSession.CurrentSession().call package name serializedRVal [| |] [| |] @@>) :> MemberInfo ] ) + + yield pns, [ pty ] } + + /// Check if R is installed - if no, generate type with properties displaying + /// the error message, otherwise go ahead and use 'generateTypes'! + let initAndGenerate providerAssembly = + [ // Get the assembly and namespace used to house the provided types + Logging.logf "initAndGenerate: starting" + let ns = "RProvider" + + match GetServer().RInitValue with + | Some error -> + // add an error static property (shown when typing `R.`) + let pty = ProvidedTypeDefinition(providerAssembly, ns, "R", Some(typeof)) + let prop = ProvidedProperty("", typeof, IsStatic = true, GetterCode = fun _ -> <@@ error @@>) + prop.AddXmlDoc error + pty.AddMember prop + yield ns, [ pty ] + // add an error namespace (shown when typing `open RProvider.`) + yield ns + ".Error: " + error, [ pty ] + | _ -> + yield! generateTypes ns providerAssembly + Logging.logf "initAndGenerate: finished" ] \ No newline at end of file diff --git a/src/RProvider/RTypeBuilder.fs b/src/RProvider/RTypeBuilder.fs index 3b15cf0a..ec6af293 100644 --- a/src/RProvider/RTypeBuilder.fs +++ b/src/RProvider/RTypeBuilder.fs @@ -29,6 +29,7 @@ module internal RTypeBuilder = let pns = ns + "." + package let pty = ProvidedTypeDefinition(asm, pns, "R", Some(typeof)) + // Note use of withServer - this helps ensure we'll try to recovery from a crashed session pty.AddXmlDocDelayed <| fun () -> withServer <| fun serverDelayed -> serverDelayed.GetPackageDescription package pty.AddMembersDelayed( fun () -> withServer <| fun serverDelayed -> diff --git a/src/RProvider/RemoteRTypeBuilder.fs b/src/RProvider/RemoteRTypeBuilder.fs new file mode 100644 index 00000000..88963b44 --- /dev/null +++ b/src/RProvider/RemoteRTypeBuilder.fs @@ -0,0 +1,110 @@ +namespace RProvider + +open System +open System.Collections.Generic +open System.Reflection +open System.IO +open System.Diagnostics +open System.Threading +open Samples.FSharp.ProvidedTypes +open Microsoft.FSharp.Core.CompilerServices +open RProvider +open RProvider.Internal +open RInterop +open RInteropInternal +open RInteropClient +open Microsoft.Win32 +open System.IO + +module internal RemoteRTypeBuilder = + + let generateTypes remoteSession (parentType: ProvidedTypeDefinition) = + withServer <| fun server -> + Logging.logf "generateTypes for remote R session: getting packages" + for package in server.GetPackages(remoteSession) do + let pty = ProvidedTypeDefinition(package, Some(typeof), HideObjectMethods = true) + pty.AddXmlDocDelayed <| fun () -> withServer <| fun serverDelayed -> serverDelayed.GetPackageDescription(package, remoteSession) + pty.AddMembersDelayed(fun () -> + withServer <| fun serverDelayed -> + [ let bindings = serverDelayed.GetBindings(package, remoteSession) + let titles = lazy serverDelayed.GetFunctionDescriptions(package, remoteSession) + for name, rval in Map.toSeq bindings do + let memberName = makeSafeName name + + // Serialize RValue to a string, so that we can include it in the + // compiled quotation (and do not have to get the info again at runtime) + let serializedRVal = RInterop.serializeRValue rval + + match rval with + | RValue.Function(paramList, hasVarArgs) -> + let paramList = + [ for p in paramList -> + ProvidedParameter(makeSafeName p, typeof, optionalValue=null) + + if hasVarArgs then + yield ProvidedParameter("paramArray", typeof, optionalValue=null, isParamArray=true) + ] + let paramCount = paramList.Length + + let pm = ProvidedMethod( + methodName = memberName, + parameters = paramList, + returnType = typeof, + InvokeCode = fun args -> + if args.Length <> paramCount+1 then // expect arg 0 is RemoteSession + failwithf "Expected %d arguments and received %d" paramCount args.Length + if hasVarArgs then + let namedArgs = + Array.sub (Array.ofList args) 1 (paramCount-1) + |> List.ofArray + let namedArgs = Quotations.Expr.NewArray(typeof, namedArgs) + let varArgs = args.[paramCount] + <@@ ((%%args.[0]:obj) :?> RemoteSession).call package name serializedRVal %%namedArgs %%varArgs @@> + else + let namedArgs = + Array.sub (Array.ofList args) 1 (args.Length-1) + |> List.ofArray + let namedArgs = Quotations.Expr.NewArray(typeof, namedArgs) + <@@ ((%%args.[0]:obj) :?> RemoteSession).call package name serializedRVal %%namedArgs [||] @@> + ) + pm.AddXmlDocDelayed ( + fun () -> + match titles.Value.TryFind name with + | Some docs -> docs + | None -> "No documentation available" + ) + yield pm :> MemberInfo + + let pdm = ProvidedMethod( + methodName = memberName, + parameters = [ ProvidedParameter("paramsByName", typeof>) ], + returnType = typeof, + InvokeCode = fun args -> + if args.Length <> 2 then + failwithf "Expected 2 arguemnts and received %d" args.Length + let argsByName = args.[1] + <@@ let vals = %%argsByName: IDictionary + let valSeq = vals :> seq> + ((%%args.[0]:obj) :?> RemoteSession).callFunc package name valSeq null @@> + ) + yield pdm :> MemberInfo + + | _ -> + let serializedRVal = RInterop.serializeRValue RValue.Value + yield ProvidedProperty( + propertyName = memberName, + propertyType = typeof, + GetterCode = fun args -> <@@ ((%%args.[0]:obj) :?> RemoteSession).call package name serializedRVal [||] [||] @@> + ) :> MemberInfo + ] + ) + + parentType.AddMember pty + let ptyName = pty.Name + let prop = + ProvidedProperty( + propertyName = pty.Name, + propertyType = pty, + GetterCode = fun args -> <@@ %%args.[0] @@> + ) + parentType.AddMember prop \ No newline at end of file diff --git a/src/RProvider/RemoteSession.fs b/src/RProvider/RemoteSession.fs new file mode 100644 index 00000000..e4814bed --- /dev/null +++ b/src/RProvider/RemoteSession.fs @@ -0,0 +1,258 @@ +namespace RProvider + +open Microsoft.FSharp.Reflection +open RDotNet +open RProvider.Internal +open RProvider.Internal.Logging +open RProvider.Internal.RInit +open RProvider.RInterop +open RProvider.RInteropInternal +open System +open System.Collections.Generic +open System.Diagnostics +open System.IO +open System.Reflection +open System.Threading + +type public SessionConfig(hostName: string, port: int, blocking: bool, ?timeout: int) = + member this.hostName = hostName + member this.port = port + member this.blocking = blocking + member this.timeout = defaultArg timeout 2 + +type RemoteSymbolicExpression(getValue: RemoteSymbolicExpression -> SymbolicExpression, name) = + member this.name = name + + // Retrieves the value of the handle from the remote session + member this.GetValue () = + getValue(this) + +type LaunchResult<'T> = + | LaunchResult of 'T + | LaunchError of string + +type RemoteSession(connectionName) as this= + static member LaunchRProfile port = + let rprofileFmt = sprintf """ + .First <- function() { + if (!(require(svSocket))) { + install.packages("svSocket", dependencies = TRUE) + # library will raise an error if the package is still not installed + library(svSocket) + } + startSocketServer(port = %d) + } + + .Last <- function() { + closeSocketClients(sockets = "all", serverport = %d) + stopSocketServer(port = %d) + } + """ + rprofileFmt port port port + + static member GetConnection(?host, ?port, ?blocking, ?timeout) = + let host = defaultArg host "localhost" + let port = defaultArg port 8888 + let blocking = + match blocking with + | Some true -> "TRUE" + | _ -> "FALSE" + let timeout = defaultArg timeout 2 // seconds + let connectionName = getNextSymbolName() + loadPackage("svSocket") + let conn = eval(sprintf "%s <- tryCatch( {socketConnection(host='%s', port='%d', blocking='%s', timeout='%d')}, error=function(cond) {return(NULL)}, warning=function(cond) {return(NULL)})" connectionName host port blocking timeout) + if (eval(sprintf "is.null(%s)" connectionName).GetValue()) then + failwith (sprintf "Failed to connect to remote R session with host %s on port %d. Are you sure that the R host application is running?" host port) + else + new RemoteSession(connectionName) + + static member GetConnection(config: SessionConfig) = + RemoteSession.GetConnection(host=config.hostName, port=config.port, blocking=config.blocking, timeout=config.timeout) + + static member LaunchRGui (?port: int, ?fileName: string) = + match RInit.initResult.Value with + | RInitError error -> LaunchError error + | RInitResult location -> + try + let tempDirectory = Path.GetTempFileName() + File.Delete(tempDirectory) + Directory.CreateDirectory(tempDirectory) |> ignore + let rprofilePath = Path.Combine(tempDirectory, ".Rprofile") + let tempFS = new StreamWriter(rprofilePath) + let port = defaultArg port 8888 + let fileName = defaultArg fileName "Rgui" + tempFS.Write(RemoteSession.LaunchRProfile port) + tempFS.Flush() + tempFS.Close() + let startInfo = ProcessStartInfo(UseShellExecute=false, fileName=fileName, WorkingDirectory=tempDirectory) + let p = Process.Start(startInfo, EnableRaisingEvents=false) + p.Exited.Add(fun _ -> + File.Delete(rprofilePath) + Directory.Delete(tempDirectory) + ) + LaunchResult p + with e -> + reraise() + + member this.connectionName = connectionName + member this.isClosed = false + + member this.makeSafeExpr (expr: string) = + expr.Replace("\"","\\\\\"").Replace("'", "\\\\\\'").Replace("\n", "\\\\n").Replace("\r", "") + + member this.evalToSymbolicExpression expr = + let expr = this.makeSafeExpr expr + eval(sprintf """evalServer(%s, '%s')""" connectionName expr) + + member this.getHandleValue (handle: RemoteSymbolicExpression) = + this.evalToSymbolicExpression(handle.name) + + member this.evalToHandle expr = + let handleName = getNextSymbolName() + let expr = this.makeSafeExpr expr + eval(sprintf "evalServer(%s, '%s <- %s; TRUE')" connectionName handleName expr) |> ignore + new RemoteSymbolicExpression(this.getHandleValue, handleName) + + member this.exec expr = + let expr = this.makeSafeExpr expr + eval(sprintf "evalServer(%s, '%s'); TRUE');" this.connectionName expr) |> ignore + + member this.assign name value = + let symbolName, se = toR value + eval(sprintf "evalServer(%s, %s, %s)" this.connectionName name symbolName) |> ignore + + member this.getRemoteSymbol name = + this.evalToSymbolicExpression name + + member this.resolveHandle (arg: obj) (temporaryHandles: System.Collections.Generic.List) = + match arg with + | null -> null + | arg when arg.GetType() = typeof -> + new StringLiteral((arg :?> RemoteSymbolicExpression).name) :> obj + | arg -> + let symbolName = getNextSymbolName() + temporaryHandles.Add(symbolName) + this.assign symbolName arg + new StringLiteral(symbolName) :> obj + + member this.resolveHandles (args: obj[]) (temporaryHandles: System.Collections.Generic.List) = + if args <> null then + [| for arg in args -> this.resolveHandle arg temporaryHandles |] + else args + + member this.clearTemporaryHandles (temporaryHandles: System.Collections.Generic.List) = + eval(sprintf "evalServer(%s, 'rm(%s); TRUE')" this.connectionName (System.String.Join(",", temporaryHandles))) |> ignore + + member this.call (packageName: string) (funcName: string) (serializedRVal:string) (namedArgs: obj[]) (varArgs: obj[]) : RemoteSymbolicExpression = + let temporaryHandles = System.Collections.Generic.List() + let namedArgs = this.resolveHandles namedArgs temporaryHandles + let varArgs = this.resolveHandles varArgs temporaryHandles + let result = call_ this.evalToHandle packageName funcName serializedRVal namedArgs varArgs + this.clearTemporaryHandles temporaryHandles + result + + member this.callFunc (packageName: string) (funcName: string) (argsByName: seq>) (varArgs: obj[]) : RemoteSymbolicExpression = + let temporaryHandles = System.Collections.Generic.List() + let argsByName = + Seq.map + (fun (a: KeyValuePair) -> new KeyValuePair(a.Key, (this.resolveHandle a.Value temporaryHandles))) + argsByName + let result = callFunc_ this.evalToHandle packageName funcName argsByName varArgs + this.clearTemporaryHandles temporaryHandles + result + + member val cache_getPackages = lazy(getPackages_ this.evalToSymbolicExpression) + + member this.getPackages ?useCache : string[] = + let useCache = defaultArg useCache true + match useCache with + | true -> this.cache_getPackages.Force() + | false -> getPackages_ this.evalToSymbolicExpression + + member this.getCached useCache (cache : Dictionary<_,_>) key lookup = + match useCache with + | true when cache.ContainsKey key -> cache.[key] + | true -> + let value = lookup() + cache.Add(key, value) + value + | false -> lookup() + + member this.cache_getPackageDescription = new Dictionary() + + member this.getPackageDescription(packageName, ?useCache) : string = + this.getCached + (defaultArg useCache true) + this.cache_getPackageDescription + packageName + (fun () -> getPackageDescription_ this.evalToSymbolicExpression packageName) + + member this.cache_getFunctionDescriptions = new Dictionary>() + + member this.getFunctionDescriptions(packageName, ?useCache) : Map = + this.getCached + (defaultArg useCache true) + this.cache_getFunctionDescriptions + packageName + (fun () -> getFunctionDescriptions_ this.exec this.evalToSymbolicExpression packageName) + + member this.packages = System.Collections.Generic.HashSet() + + member this.loadPackage packageName = + loadPackage_ this.evalToSymbolicExpression this.packages packageName + + member this.getBindingsFromR = + lazy + let funcHandle = this.evalToHandle RInterop.getBindingsDefn + fun packageName -> this.evalToSymbolicExpression (sprintf "%s('%s')" funcHandle.name packageName) + + member this.getBindings packageName = + getBindings_ this.getBindingsFromR.Value packageName + + member this.serializeRValue = serializeRValue + + member this.deserializeRValue = deserializeRValue + + member this.close () = + eval(sprintf "close(%s)" this.connectionName) |> ignore + + override this.Finalize () = + if not this.isClosed then + this.close() + +type RRSession (session) = + [] + static val mutable private threadSessions : Stack + + static member private Sessions = + if RRSession.threadSessions = null then + RRSession.threadSessions <- new Stack() + RRSession.threadSessions + + static member GetSession (hostname, port, blocking, timeout) = + RRSession.Sessions.Push( + RemoteSession.GetConnection(hostname, port, blocking, timeout)) + RRSession.Sessions.Peek() + + static member CurrentSession () = + if RRSession.Sessions.Count > 0 then + RRSession.Sessions.Peek() + else + failwith "No current RemoteSession" + + new(?hostname, ?port, ?blocking, ?timeout) = + new RRSession( + RRSession.GetSession( + defaultArg hostname "localhost", + defaultArg port 8888, + defaultArg blocking false, + defaultArg timeout 2)) + + let mutable disposed = false + + interface IDisposable with + member this.Dispose() = + if not disposed then + RRSession.Sessions.Pop() |> ignore + session.close() + disposed <- true diff --git a/src/RProvider/app.config b/src/RProvider/app.config index 49e65ce0..e916442e 100644 --- a/src/RProvider/app.config +++ b/src/RProvider/app.config @@ -5,11 +5,5 @@ - - - - - - \ No newline at end of file