From 4e67b98fc07406c3c9ab9d14448835096588c09f Mon Sep 17 00:00:00 2001 From: David Charboneau Date: Tue, 29 Apr 2014 10:01:43 -0400 Subject: [PATCH 1/7] Define RemoteSession for Remote R access RemoteSession provides a way to create a connection to a remote R process via the svSocket package for R. Some functions in RInterop are generalized to allow as much reuse as possible for functions that perform the same behavior whether local or remote. --- src/RProvider/RInterop.fs | 131 +++++++++++++-------- src/RProvider/RProvider.Runtime.fsproj | 4 + src/RProvider/RemoteSession.fs | 154 +++++++++++++++++++++++++ 3 files changed, 239 insertions(+), 50 deletions(-) create mode 100644 src/RProvider/RemoteSession.fs diff --git a/src/RProvider/RInterop.fs b/src/RProvider/RInterop.fs index 53384728..d9cc219c 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,24 +345,36 @@ 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) { require(pkgName, character.only=TRUE) @@ -377,11 +392,15 @@ module RInterop = } ) }""" + + let internal 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/RProvider.Runtime.fsproj b/src/RProvider/RProvider.Runtime.fsproj index 5721ad99..dded3a6f 100644 --- a/src/RProvider/RProvider.Runtime.fsproj +++ b/src/RProvider/RProvider.Runtime.fsproj @@ -62,6 +62,10 @@ + + + + diff --git a/src/RProvider/RemoteSession.fs b/src/RProvider/RemoteSession.fs new file mode 100644 index 00000000..66bade28 --- /dev/null +++ b/src/RProvider/RemoteSession.fs @@ -0,0 +1,154 @@ +namespace RProvider + +open Microsoft.FSharp.Reflection +open RDotNet +open RProvider.Internal.Logging +open RProvider.RInterop +open RProvider.RInteropInternal +open System +open System.Collections.Generic +open System.Reflection + +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 RemoteSession(connectionName) as this= + static member GetConnection(?host, ?port, ?blocking) = + let host = defaultArg host "localhost" + let port = defaultArg port 8888 + let blocking = + match blocking with + | Some true -> "TRUE" + | _ -> "FALSE" + let connectionName = getNextSymbolName() + loadPackage("svSocket") + eval(sprintf "%s <- socketConnection(host='%s', port='%d', blocking='%s')" connectionName host port blocking) |> ignore + new RemoteSession(connectionName) + + 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, 'exec(%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 this.bindingInfo (name: string) : RValue = +// bindingInfo_ this.evalToSymbolicExpression name + + 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.getBindings packageName = + getBindings_ this.evalToSymbolicExpression 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() \ No newline at end of file From 37d098948ad654f58fd568761f3f351fb7245e9d Mon Sep 17 00:00:00 2001 From: David Charboneau Date: Tue, 29 Apr 2014 16:12:15 -0400 Subject: [PATCH 2/7] Add RemoteR type provider The RemoteR type provider provides a way to import and export data between F# and R sessions, as well as make remote calls to a running R session. --- RProvider.sln | 1 + docs/content/tutorial-RemoteR.fsx | 113 +++++++++++++++++++++ src/RProvider/RInterop.fs | 4 +- src/RProvider/RInteropClient.fs | 13 ++- src/RProvider/RInteropServer.fs | 28 ++++++ src/RProvider/RProvider.DesignTime.fsproj | 2 + src/RProvider/RProvider.fs | 114 ++++++++++++++++++++++ src/RProvider/RTypeBuilder.fs | 1 + src/RProvider/RemoteRTypeBuilder.fs | 110 +++++++++++++++++++++ src/RProvider/RemoteSession.fs | 17 +++- 10 files changed, 398 insertions(+), 5 deletions(-) create mode 100644 docs/content/tutorial-RemoteR.fsx create mode 100644 src/RProvider/RemoteRTypeBuilder.fs 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 d9cc219c..2f50f9cc 100644 --- a/src/RProvider/RInterop.fs +++ b/src/RProvider/RInterop.fs @@ -376,7 +376,7 @@ module RInterop = 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( @@ -393,7 +393,7 @@ module RInterop = ) }""" - let internal getBindingsFromR_ evalTo eval = + let getBindingsFromR_ evalTo eval = let symbolName = getNextSymbolName() evalTo (getBindingsDefn.Replace("\r","")) symbolName fun packageName -> eval (sprintf "%s('%s')" symbolName packageName) 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..803106b8 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) = + withLock <| fun () -> + x.GetRemoteSession(remoteSession).getPackages() + member x.LoadPackage(package) = exceptionSafe <| fun () -> loadPackage package + + member x.LoadPackage(package, remoteSession) = + withLock <| fun () -> + x.GetRemoteSession(remoteSession).loadPackage package + member x.GetBindings(package, remoteSession) = + withLock <| fun () -> + x.GetRemoteSession(remoteSession).getBindings package + member x.GetBindings(package) = exceptionSafe <| fun () -> getBindings package + member x.GetFunctionDescriptions(package:string, remoteSession) = + withLock <| fun () -> + x.GetRemoteSession(remoteSession).getFunctionDescriptions package + member x.GetFunctionDescriptions(package:string) = exceptionSafe <| fun () -> getFunctionDescriptions package + member x.GetPackageDescription(package, remoteSession) = + withLock <| 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..b5b9aa13 100644 --- a/src/RProvider/RProvider.DesignTime.fsproj +++ b/src/RProvider/RProvider.DesignTime.fsproj @@ -61,6 +61,8 @@ + + diff --git a/src/RProvider/RProvider.fs b/src/RProvider/RProvider.fs index 0df99ef2..e07a49ec 100644 --- a/src/RProvider/RProvider.fs +++ b/src/RProvider/RProvider.fs @@ -36,3 +36,117 @@ type public RProvider(cfg:TypeProviderConfig) as this = Logging.logf "RProvider constructor failed: %O" e reraise() do buildTypes () + +[] +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" + 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/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..eb592061 --- /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 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 index 66bade28..e853e553 100644 --- a/src/RProvider/RemoteSession.fs +++ b/src/RProvider/RemoteSession.fs @@ -9,6 +9,11 @@ open System open System.Collections.Generic open System.Reflection +type public SessionConfig(hostName: string, port: int, blocking: bool) = + member this.hostName = hostName + member this.port = port + member this.blocking = blocking + type RemoteSymbolicExpression(getValue: RemoteSymbolicExpression -> SymbolicExpression, name) = member this.name = name @@ -29,6 +34,9 @@ type RemoteSession(connectionName) as this= eval(sprintf "%s <- socketConnection(host='%s', port='%d', blocking='%s')" connectionName host port blocking) |> ignore new RemoteSession(connectionName) + static member GetConnection(config: SessionConfig) = + RemoteSession.GetConnection(host=config.hostName, port=config.port, blocking=config.blocking) + member this.connectionName = connectionName member this.isClosed = false @@ -50,7 +58,7 @@ type RemoteSession(connectionName) as this= member this.exec expr = let expr = this.makeSafeExpr expr - eval(sprintf "evalServer(%s, 'exec(%s); TRUE');" this.connectionName expr) |> ignore + eval(sprintf "evalServer(%s, '%s'); TRUE');" this.connectionName expr) |> ignore member this.assign name value = let symbolName, se = toR value @@ -139,8 +147,13 @@ type RemoteSession(connectionName) as this= 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.evalToSymbolicExpression packageName + getBindings_ this.getBindingsFromR.Value packageName member this.serializeRValue = serializeRValue From 5d412d25cc12426313bf4dd2ef71286cc7b31953 Mon Sep 17 00:00:00 2001 From: David Charboneau Date: Wed, 30 Apr 2014 14:29:10 -0400 Subject: [PATCH 3/7] Launch local RGui from fsi for a RemoteSession Enable launch of RGui from fsi. Ensure that svSocket is installed and launch the socket server. --- src/RProvider/RemoteSession.fs | 56 +++++++++++++++++++++++++++++++--- 1 file changed, 52 insertions(+), 4 deletions(-) diff --git a/src/RProvider/RemoteSession.fs b/src/RProvider/RemoteSession.fs index e853e553..f81b2082 100644 --- a/src/RProvider/RemoteSession.fs +++ b/src/RProvider/RemoteSession.fs @@ -2,11 +2,15 @@ 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 type public SessionConfig(hostName: string, port: int, blocking: bool) = @@ -21,7 +25,29 @@ type RemoteSymbolicExpression(getValue: RemoteSymbolicExpression -> SymbolicExpr 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) = let host = defaultArg host "localhost" let port = defaultArg port 8888 @@ -36,7 +62,32 @@ type RemoteSession(connectionName) as this= static member GetConnection(config: SessionConfig) = RemoteSession.GetConnection(host=config.hostName, port=config.port, blocking=config.blocking) - + + 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 @@ -104,9 +155,6 @@ type RemoteSession(connectionName) as this= this.clearTemporaryHandles temporaryHandles result -// member this.bindingInfo (name: string) : RValue = -// bindingInfo_ this.evalToSymbolicExpression name - member val cache_getPackages = lazy(getPackages_ this.evalToSymbolicExpression) member this.getPackages ?useCache : string[] = From bf0d15762fcb5d89139d7c862eb028ba8322a874 Mon Sep 17 00:00:00 2001 From: David Charboneau Date: Tue, 6 May 2014 13:35:52 -0400 Subject: [PATCH 4/7] Better connection error handling When the R svSocket server isn't running produce a better error message. Also, set a default timeout so that the type provider doesn't hang waiting for the R svSocket server if it isn't running. --- src/RProvider/RemoteSession.fs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/RProvider/RemoteSession.fs b/src/RProvider/RemoteSession.fs index f81b2082..ab348c5e 100644 --- a/src/RProvider/RemoteSession.fs +++ b/src/RProvider/RemoteSession.fs @@ -13,10 +13,11 @@ open System.Diagnostics open System.IO open System.Reflection -type public SessionConfig(hostName: string, port: int, blocking: bool) = +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 @@ -48,20 +49,24 @@ type RemoteSession(connectionName) as this= """ rprofileFmt port port port - static member GetConnection(?host, ?port, ?blocking) = + 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") - eval(sprintf "%s <- socketConnection(host='%s', port='%d', blocking='%s')" connectionName host port blocking) |> ignore - new RemoteSession(connectionName) - + 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) + 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 From ed87239c0645092a4db549bee7c595628d706e0e Mon Sep 17 00:00:00 2001 From: David Charboneau Date: Wed, 14 May 2014 15:20:46 -0400 Subject: [PATCH 5/7] Fix merge errors from rebasing on master. --- src/RProvider/RInteropServer.fs | 10 +++++----- src/RProvider/RProvider.DesignTime.fsproj | 3 +-- src/RProvider/RProvider.Runtime.fsproj | 2 -- src/RProvider/RProvider.fs | 16 ++++++++-------- src/RProvider/RemoteRTypeBuilder.fs | 2 +- 5 files changed, 15 insertions(+), 18 deletions(-) diff --git a/src/RProvider/RInteropServer.fs b/src/RProvider/RInteropServer.fs index 803106b8..a8c4a112 100644 --- a/src/RProvider/RInteropServer.fs +++ b/src/RProvider/RInteropServer.fs @@ -39,7 +39,7 @@ type RInteropServer() = getPackages() member x.GetPackages(remoteSession) = - withLock <| fun () -> + exceptionSafe <| fun () -> x.GetRemoteSession(remoteSession).getPackages() member x.LoadPackage(package) = @@ -47,11 +47,11 @@ type RInteropServer() = loadPackage package member x.LoadPackage(package, remoteSession) = - withLock <| fun () -> + exceptionSafe <| fun () -> x.GetRemoteSession(remoteSession).loadPackage package member x.GetBindings(package, remoteSession) = - withLock <| fun () -> + exceptionSafe <| fun () -> x.GetRemoteSession(remoteSession).getBindings package member x.GetBindings(package) = @@ -59,7 +59,7 @@ type RInteropServer() = getBindings package member x.GetFunctionDescriptions(package:string, remoteSession) = - withLock <| fun () -> + exceptionSafe <| fun () -> x.GetRemoteSession(remoteSession).getFunctionDescriptions package member x.GetFunctionDescriptions(package:string) = @@ -67,7 +67,7 @@ type RInteropServer() = getFunctionDescriptions package member x.GetPackageDescription(package, remoteSession) = - withLock <| fun () -> + exceptionSafe <| fun () -> x.GetRemoteSession(remoteSession).getPackageDescription package member x.GetPackageDescription(package) = diff --git a/src/RProvider/RProvider.DesignTime.fsproj b/src/RProvider/RProvider.DesignTime.fsproj index b5b9aa13..3d41e9c0 100644 --- a/src/RProvider/RProvider.DesignTime.fsproj +++ b/src/RProvider/RProvider.DesignTime.fsproj @@ -59,10 +59,9 @@ + - - diff --git a/src/RProvider/RProvider.Runtime.fsproj b/src/RProvider/RProvider.Runtime.fsproj index dded3a6f..32509a89 100644 --- a/src/RProvider/RProvider.Runtime.fsproj +++ b/src/RProvider/RProvider.Runtime.fsproj @@ -63,9 +63,7 @@ - - diff --git a/src/RProvider/RProvider.fs b/src/RProvider/RProvider.fs index e07a49ec..9229df9a 100644 --- a/src/RProvider/RProvider.fs +++ b/src/RProvider/RProvider.fs @@ -91,8 +91,8 @@ type public RProviderRemote(cfg:TypeProviderConfig) as this = 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] @@> + failwithf "Expected 2 argument and received %d" args.Length + <@@ ((%%args.[0]:obj) :?> RemoteSession).evalToHandle %%args.[1] @@> ) sessionType.AddMember sessionEvalToHandle @@ -102,8 +102,8 @@ type public RProviderRemote(cfg:TypeProviderConfig) as this = 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] @@> + failwithf "Expected 2 argument and received %d" args.Length + <@@ ((%%args.[0]:obj) :?> RemoteSession).evalToSymbolicExpression %%args.[1] @@> ) sessionType.AddMember sessionEvalToSymbolicExpression @@ -113,8 +113,8 @@ type public RProviderRemote(cfg:TypeProviderConfig) as this = 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] @@> + failwithf "Expected 3 argument and received %d" args.Length + <@@ ((%%args.[0]:obj) :?> RemoteSession).assign %%args.[1] %%args.[2] @@> ) sessionType.AddMember sessionAssign @@ -124,8 +124,8 @@ type public RProviderRemote(cfg:TypeProviderConfig) as this = 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] @@> + failwithf "Expected 2 argument and received %d" args.Length + <@@ ((%%args.[0]:obj) :?> RemoteSession).getRemoteSymbol %%args.[1] @@> ) sessionType.AddMember sessionGet diff --git a/src/RProvider/RemoteRTypeBuilder.fs b/src/RProvider/RemoteRTypeBuilder.fs index eb592061..88963b44 100644 --- a/src/RProvider/RemoteRTypeBuilder.fs +++ b/src/RProvider/RemoteRTypeBuilder.fs @@ -16,7 +16,7 @@ open RInteropClient open Microsoft.Win32 open System.IO -module RemoteRTypeBuilder = +module internal RemoteRTypeBuilder = let generateTypes remoteSession (parentType: ProvidedTypeDefinition) = withServer <| fun server -> From 4c4462d0830f856c352fa1969636626308a8f2c3 Mon Sep 17 00:00:00 2001 From: David Charboneau Date: Fri, 20 Jun 2014 13:08:17 -0400 Subject: [PATCH 6/7] Merge in latest from BlueMountain master The addition of the RData paramterized type caused problems resolving the RemoteR type. To fix this, the RemoteR type was moved to the RProvider.Remote namespace. There appears to be a limitation in the F# type provider facility restricting the number of parameterized type providers to one per namespace. --- src/RProvider/RProvider.DesignTime.fsproj | 1 + src/RProvider/RProvider.fs | 114 -------------------- src/RProvider/RProviderRemote.fs | 126 ++++++++++++++++++++++ 3 files changed, 127 insertions(+), 114 deletions(-) create mode 100644 src/RProvider/RProviderRemote.fs diff --git a/src/RProvider/RProvider.DesignTime.fsproj b/src/RProvider/RProvider.DesignTime.fsproj index 3d41e9c0..01baf638 100644 --- a/src/RProvider/RProvider.DesignTime.fsproj +++ b/src/RProvider/RProvider.DesignTime.fsproj @@ -61,6 +61,7 @@ + diff --git a/src/RProvider/RProvider.fs b/src/RProvider/RProvider.fs index 9229df9a..0df99ef2 100644 --- a/src/RProvider/RProvider.fs +++ b/src/RProvider/RProvider.fs @@ -36,117 +36,3 @@ type public RProvider(cfg:TypeProviderConfig) as this = Logging.logf "RProvider constructor failed: %O" e reraise() do buildTypes () - -[] -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" - 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/RProviderRemote.fs b/src/RProvider/RProviderRemote.fs new file mode 100644 index 00000000..6af80bf7 --- /dev/null +++ b/src/RProvider/RProviderRemote.fs @@ -0,0 +1,126 @@ +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 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]) + + From 80b7fad43e8593892a3b159a44a1f07e44e2d0f0 Mon Sep 17 00:00:00 2001 From: David Charboneau Date: Tue, 8 Jul 2014 13:15:09 -0400 Subject: [PATCH 7/7] Add RR type provider for remote sessions. The new RR type provider works much the same as the R type provider, but requires that there be an active session in the current thread. To use, you create an RRSession. For example: use session = RRSession("localhost", 8888) let remoteSymbolicHandle = RR.c(1,2,3) --- src/RProvider/RProvider.DesignTime.fsproj | 2 + src/RProvider/RProvider.fs | 1 + src/RProvider/RProviderRemote.fs | 1 + src/RProvider/RRProvider.fs | 39 +++++++ src/RProvider/RRTypeBuilder.fs | 125 ++++++++++++++++++++++ src/RProvider/RemoteSession.fs | 40 ++++++- src/RProvider/app.config | 6 -- 7 files changed, 207 insertions(+), 7 deletions(-) create mode 100644 src/RProvider/RRProvider.fs create mode 100644 src/RProvider/RRTypeBuilder.fs diff --git a/src/RProvider/RProvider.DesignTime.fsproj b/src/RProvider/RProvider.DesignTime.fsproj index 01baf638..b6d4d4b7 100644 --- a/src/RProvider/RProvider.DesignTime.fsproj +++ b/src/RProvider/RProvider.DesignTime.fsproj @@ -59,8 +59,10 @@ + + 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 index 6af80bf7..3deb1238 100644 --- a/src/RProvider/RProviderRemote.fs +++ b/src/RProvider/RProviderRemote.fs @@ -9,6 +9,7 @@ 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() 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/RemoteSession.fs b/src/RProvider/RemoteSession.fs index ab348c5e..e4814bed 100644 --- a/src/RProvider/RemoteSession.fs +++ b/src/RProvider/RemoteSession.fs @@ -12,6 +12,7 @@ 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 @@ -217,4 +218,41 @@ type RemoteSession(connectionName) as this= override this.Finalize () = if not this.isClosed then - this.close() \ No newline at end of file + 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