diff --git a/RELEASE_NOTES.md b/RELEASE_NOTES.md index 3e876973..93bc953e 100644 --- a/RELEASE_NOTES.md +++ b/RELEASE_NOTES.md @@ -10,4 +10,5 @@ * 1.0.12 - Use correct folders in NuGet package * 1.0.13 - Fix the Print extension method * 1.0.14 - Fix the module clash error in FsLab (#46). Fix assembly resolution (#117). Update NuGET and automatically update FAKE(#116). -* 1.0.15 - Fix bad upload to NuGet.org \ No newline at end of file +* 1.0.15 - Fix bad upload to NuGet.org +* 1.0.16-rc1 - RemoteSession for Remote R session interaction \ No newline at end of file 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..70f4f02a --- /dev/null +++ b/docs/content/tutorial-RemoteR.fsx @@ -0,0 +1,178 @@ +(*** 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 + +## Introduction + +Interaction with R sessions running in a separate process, or even a separate machine +on the network, can be performed using the RProvider.RemoteSession class. The +RemoteSession class can copy variables to the remote R session, as well as from the +remote R session, and invoke arbitrary R code in the remote session. + +This can be very useful if you want to switch between working in Fsi and working in +RGui or RStudio, or if you want to offload some processing in R to another machine. + +To make the experience of using RemoteSession instances more like using the R type +provided by RProvider the RemoteR type provider extends the RemoteSession class +with methods and properties corresponding to functions and properties defined by R packages +for the local R installation. R packages referenced by the module "open" syntax will have +their functions and properties automatically added to the RemoteSession class, just as they +are for the R type. It's important to remember that type discovery is performed using the +local R installation; if you are connected to an R session running on a separate machine +it may not have the package you reference installed and attempting to call a function in +the remote R session provided by a package that isn't installed on that machine will result +in a runtime error. + +## Pre-requisites + +The RemoteSession class requires the svSocket package in R. This package must be installed +in R for the local R installation. If you connect to a remote machine, the R installation +for that remote machine must also have the svSocket package installed. + +As of 8/1/2014 a patched version of the compiler is required for the type provider that adds +the extension methods to RemoteSession. The source for this version and can be downloaded from +of the compiler can be downloaded and built from here: +[Extension Methods fork on CodePlex](https://visualfsharp.codeplex.com/SourceControl/network/forks/dsyme/cleanup/contribution/6853) + +## Tutorial Setup + +These instructions assume that you are running RGui or RStudio on the same machine as you +are running Fsi. + + * Start RGui or RStudio + * Make sure that svSocket package is installed + * In R, `require(svSocket)` + * In R, `startSocketServer()` + +## 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 +(** +These statements import the R packages named. Discovery of the packages is performed +using the local R installation. +*) +open RProvider.``base`` +open RProvider.stats +open RProvider.tseries +open RProvider.graphics + +open System +open System.Net + +/// Constructs a new RemoteSession. If you've compiled with an F# compiler that supports +/// generating extension methods the RR instance will provide the same functions as the +/// R type would given the R package imports above: base, stats, tseries, and graphics +let RR = new RemoteSession() + +(** +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.log |> RR.diff + +/// Alternately, the RemoteR class is provided which is equivalent to the R class; however, +/// it takes a RemoteSession instance as the first argument and uses that RemoteSession instance +/// to make all R calls. +///let msft = msftOpens |> (fun a -> RemoteR.log(RR, a) |> (fun a -> RemoteR.diff(RR, a) + +(** +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.acf(msft) +let adf = RR.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.log |> RR.diff ] + +// Create an R data frame with the data and call 'R.pairs' +let df = RR.data_frame(namedParams data) +RR.pairs(df) + +// Create variable in the remote session and copy a value to it +RR?foo <- "foo" +// Retrieve a remote variable as a RemoteSymbolicExpression +let remoteFoo = RR?foo +// Get a local SymbolicExpression for the remote one +let localFoo = remoteFoo.ToLocalValue() +// Get an unnamed RemoteSymbolicExpression for a value +(32).ToRemoteValue(RR) + +(** +As a result, you should see a window showing results similar to these: + +
+ +
+ +*) diff --git a/src/Common/AssemblyInfo.fs b/src/Common/AssemblyInfo.fs index 5b4a4494..b09bafe0 100644 --- a/src/Common/AssemblyInfo.fs +++ b/src/Common/AssemblyInfo.fs @@ -5,9 +5,9 @@ open System.Reflection [] [] [] -[] -[] +[] +[] do () module internal AssemblyVersionInformation = - let [] Version = "1.0.15" + let [] Version = "1.0.16" diff --git a/src/Common/ProvidedTypes.fs b/src/Common/ProvidedTypes.fs index abc1a331..b5d70146 100644 --- a/src/Common/ProvidedTypes.fs +++ b/src/Common/ProvidedTypes.fs @@ -19,6 +19,7 @@ open System.Reflection open System.Reflection.Emit open System.Linq.Expressions open System.Collections.Generic +open System.Runtime.CompilerServices open Microsoft.FSharp.Core.CompilerServices type E = Quotations.Expr @@ -77,6 +78,16 @@ module internal Misc = type CustomAttributeData = Microsoft.FSharp.Core.CompilerServices.IProvidedCustomAttributeData #endif + let mkExtensionAttributeData() = +#if FX_NO_CUSTOMATTRIBUTEDATA + { new IProvidedCustomAttributeData with +#else + { new CustomAttributeData() with +#endif + member __.Constructor = typeof.GetConstructors().[0] + member __.ConstructorArguments = upcast [| |] + member __.NamedArguments = upcast [||] } + let mkEditorHideMethodsCustomAttributeData() = #if FX_NO_CUSTOMATTRIBUTEDATA { new IProvidedCustomAttributeData with @@ -132,6 +143,7 @@ module internal Misc = let mutable xmlDocDelayed = None let mutable xmlDocAlwaysRecomputed = None let mutable hasParamArray = false + let mutable extensionAttribute = false // XML doc text that we only compute once, if any. This must _not_ be forced until the ConstructorArguments // property of the custom attribute is foced. @@ -155,9 +167,11 @@ module internal Misc = member __.AddXmlDocDelayed(xmlDoc : unit -> string) = xmlDocDelayed <- Some xmlDoc member this.AddXmlDoc(text:string) = this.AddXmlDocDelayed (fun () -> text) member __.HideObjectMethods with set v = hideObjectMethods <- v + member __.ExtensionAttribute with set v = extensionAttribute <- v member __.AddCustomAttribute(attribute) = customAttributes.Add(attribute) member __.GetCustomAttributesData() = [| yield! customAttributesOnce.Force() + if extensionAttribute then yield mkExtensionAttributeData() match xmlDocAlwaysRecomputed with None -> () | Some f -> customAttributes.Add(mkXmlDocCustomAttributeData (f())) |] :> IList<_> @@ -582,6 +596,7 @@ type ProvidedMethod(methodName: string, parameters: ProvidedParameter list, retu member this.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member this.ExtensionAttribute with set v = customAttributesImpl.ExtensionAttribute <- v member __.AddCustomAttribute(attribute) = customAttributesImpl.AddCustomAttribute(attribute) member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() #if FX_NO_CUSTOMATTRIBUTEDATA @@ -1239,6 +1254,7 @@ type ProvidedTypeDefinition(container:TypeContainer,className : string, baseType member this.AddObsoleteAttribute (msg,?isError) = customAttributesImpl.AddObsolete (msg,defaultArg isError false) member this.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) member this.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v + member this.ExtensionAttribute with set v = customAttributesImpl.ExtensionAttribute <- v member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() member this.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute #if FX_NO_CUSTOMATTRIBUTEDATA diff --git a/src/Common/ProvidedTypes.fsi b/src/Common/ProvidedTypes.fsi index 466ca37d..d1d5a160 100644 --- a/src/Common/ProvidedTypes.fsi +++ b/src/Common/ProvidedTypes.fsi @@ -100,6 +100,7 @@ type ProvidedMethod = /// Add a custom attribute to the provided method definition. member AddCustomAttribute : CustomAttributeData -> unit + member ExtensionAttribute : bool with set /// Represents an erased provided property. @@ -356,6 +357,8 @@ type ProvidedTypeDefinition = /// Suppress System.Object entries in intellisense menus in instances of this provided type member HideObjectMethods : bool with set + member ExtensionAttribute : bool with set + /// Get or set a flag indicating if the ProvidedTypeDefinition is erased member IsErased : bool with get,set @@ -382,6 +385,7 @@ type ProvidedAssembly = new : assemblyFileName:string -> ProvidedAssembly /// /// Emit the given provided type definitions as part of the assembly + /// and adjust the 'Assembly' property of all provided type definitions to return that /// assembly. /// diff --git a/src/RProvider/RInterop.fs b/src/RProvider/RInterop.fs index 53384728..13ac565a 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. @@ -499,7 +530,15 @@ module RInterop = /// Convert a symbolic expression to some default .NET representation let defaultFromR (sexp: SymbolicExpression) = RInteropInternal.defaultConvertFromR sexp -/// [omit] + type RSession () = + static member Singleton = new RSession() + + member this.Call (packageName: string, funcName: string, serializedRVal:string, namedArgs: obj[], varArgs: obj[]) : SymbolicExpression = + call packageName funcName serializedRVal namedArgs varArgs + + member this.CallFunc (packageName: string, funcName: string, argsByName: seq>, varArgs: obj[]) : SymbolicExpression = + callFunc packageName funcName argsByName varArgs + [] module RDotNetExtensions2 = type RDotNet.SymbolicExpression with @@ -530,4 +569,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..7a7ac444 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.GetRemoteConnection(config:SessionConfig) = + let sessionKey = (config.hostName, config.port, config.blocking) + if not (remoteSessions.ContainsKey sessionKey) then + remoteSessions <- remoteSessions.Add(sessionKey, RemoteConnection.GetConnection(config)) + remoteSessions.[sessionKey] + member x.GetPackages() = exceptionSafe <| fun () -> getPackages() + member x.GetPackages(remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteConnection(remoteSession).getPackages() + member x.LoadPackage(package) = exceptionSafe <| fun () -> loadPackage package + + member x.LoadPackage(package, remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteConnection(remoteSession).loadPackage package + member x.GetBindings(package, remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteConnection(remoteSession).getBindings package + member x.GetBindings(package) = exceptionSafe <| fun () -> getBindings package + member x.GetFunctionDescriptions(package:string, remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteConnection(remoteSession).getFunctionDescriptions package + member x.GetFunctionDescriptions(package:string) = exceptionSafe <| fun () -> getFunctionDescriptions package + member x.GetPackageDescription(package, remoteSession) = + exceptionSafe <| fun () -> + x.GetRemoteConnection(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 6f47e2ff..f36c165e 100644 --- a/src/RProvider/RProvider.DesignTime.fsproj +++ b/src/RProvider/RProvider.DesignTime.fsproj @@ -59,7 +59,9 @@ + + @@ -68,7 +70,9 @@ ..\..\packages\R.NET.Community.1.5.15\lib\net40\RDotNet.dll - + + ..\..\packages\R.NET.Community.1.5.15\lib\net40\RDotNet.NativeLibrary.dll + 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 c1101650..1b77947b 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/RProvider.fsx b/src/RProvider/RProvider.fsx index 95ca2a18..e0410d37 100644 --- a/src/RProvider/RProvider.fsx +++ b/src/RProvider/RProvider.fsx @@ -8,10 +8,10 @@ #I "../packages/R.NET.Community.1.5.15/lib/net40" #I "../../packages/R.NET.Community.1.5.15/lib/net40" #I "../../../packages/R.NET.Community.1.5.15/lib/net40" -#I "packages/RProvider.1.0.15/lib/net40" -#I "../packages/RProvider.1.0.15/lib/net40" -#I "../../packages/RProvider.1.0.15/lib/net40" -#I "../../../packages/RProvider.1.0.15/lib/net40" +#I "packages/RProvider.1.0.16-rc1/lib/net40" +#I "../packages/RProvider.1.0.16-rc1/lib/net40" +#I "../../packages/RProvider.1.0.16-rc1/lib/net40" +#I "../../../packages/RProvider.1.0.16-rc1/lib/net40" // Reference RProvider and RDotNet #r "RDotNet.dll" #r "RProvider.dll" diff --git a/src/RProvider/RTypeBuilder.fs b/src/RProvider/RTypeBuilder.fs index 3d7cc619..91c3df5e 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 -> @@ -69,10 +70,12 @@ module internal RTypeBuilder = |> List.ofArray let namedArgs = Quotations.Expr.NewArray(typeof, namedArgs) let varArgs = args.[paramCount-1] - <@@ RInterop.call package name serializedRVal %%namedArgs %%varArgs @@> + //<@@ RInterop.call package name serializedRVal %%namedArgs %%varArgs @@> + <@@ RSession.Singleton.Call(package, name, serializedRVal, %%namedArgs, %%varArgs) @@> else let namedArgs = Quotations.Expr.NewArray(typeof, args) - <@@ RInterop.call package name serializedRVal %%namedArgs [||] @@> ) + //<@@ RInterop.call package name serializedRVal %%namedArgs [||] @@> ) + <@@ RSession.Singleton.Call(package, name, serializedRVal, %%namedArgs, [||]) @@> ) pm.AddXmlDocDelayed (fun () -> match titles.Value.TryFind name with | Some docs -> docs @@ -92,15 +95,18 @@ module internal RTypeBuilder = let argsByName = args.[0] <@@ let vals = %%argsByName: IDictionary let valSeq = vals :> seq> - RInterop.callFunc package name valSeq null @@> ) - yield pdm :> MemberInfo + //RInterop.callFunc package name valSeq null @@> ) + RSession.Singleton.CallFunc(package, name, valSeq, null) @@>) + yield pdm :> MemberInfo + | RValue.Value -> yield ProvidedProperty( propertyName = memberName, propertyType = typeof, IsStatic = true, - GetterCode = fun _ -> <@@ RInterop.call package name serializedRVal [| |] [| |] @@>) :> MemberInfo ] ) - + //GetterCode = fun _ -> <@@ RInterop.call package name serializedRVal [| |] [| |] @@>) :> MemberInfo ] ) + GetterCode = fun _ -> <@@ RSession.Singleton.Call(package, name, serializedRVal, [| |], [| |]) @@>) :> MemberInfo ] ) + yield pns, [ pty ] } /// Check if R is installed - if no, generate type with properties displaying diff --git a/src/RProvider/RemoteRProvider.fs b/src/RProvider/RemoteRProvider.fs new file mode 100644 index 00000000..1a27c721 --- /dev/null +++ b/src/RProvider/RemoteRProvider.fs @@ -0,0 +1,39 @@ +namespace RProvider + +open System +open System.IO +open System.Reflection +open ProviderImplementation.ProvidedTypes +open Microsoft.FSharp.Core.CompilerServices +open RProvider +open RProvider.Internal.Configuration +open RProvider.Internal + +// Type provider for the RemoteR type (Remote R session proxied through svSocket in local R session) +[] +type public RemoteRProvider(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 RemoteRTypeBuilder.initAndGenerate(runtimeAssembly) do + this.AddNamespace(ns, types) + with e -> + Logging.logf "RemoteRProvider constructor failed: %O" e + reraise() + do buildTypes () diff --git a/src/RProvider/RemoteRTypeBuilder.fs b/src/RProvider/RemoteRTypeBuilder.fs new file mode 100644 index 00000000..21ffabcf --- /dev/null +++ b/src/RProvider/RemoteRTypeBuilder.fs @@ -0,0 +1,135 @@ +namespace RProvider + +open System +open System.Collections.Generic +open System.Reflection +open System.IO +open System.Diagnostics +open System.Threading +open ProviderImplementation.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 ns asm = + withServer <| fun server -> + seq { + for package in server.GetPackages() do + let pns = ns + "." + package + let pty = + ProvidedTypeDefinition( + asm, + pns, + "RemoteR", + Some(typeof), + ExtensionAttribute = true) + pty.AddXmlDocDelayed <| fun () -> withServer <| fun serverDelayed -> + serverDelayed.GetPackageDescription package + pty.AddMembersDelayed <| fun () -> withServer <| fun serverDelayed -> + [ serverDelayed.LoadPackage package + let bindings = serverDelayed.GetBindings package + 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 + let sessionParm = ProvidedParameter("session", typeof) + 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 = sessionParm :: paramList, + returnType = typeof, + IsStaticMethod = true, + ExtensionAttribute = true, + 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]:RemoteSession).Connection.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]:RemoteSession).Connection.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 = [ sessionParm; ProvidedParameter("paramsByName", typeof>) ], + returnType = typeof, + IsStaticMethod = true, + ExtensionAttribute = true, + 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]:RemoteSession).Connection.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).Connection.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, "RemoteR", 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" ] diff --git a/src/RProvider/RemoteSession.fs b/src/RProvider/RemoteSession.fs new file mode 100644 index 00000000..2e8b3b6c --- /dev/null +++ b/src/RProvider/RemoteSession.fs @@ -0,0 +1,262 @@ +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.Runtime.CompilerServices +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 RemoteConnection(connectionName) as this= + static let getConnection (host : string option) (port : int option) (blocking : bool option) (timeout : int option) = + 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) + connectionName + + 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) = + new RemoteConnection(getConnection host port blocking timeout) + + static member GetConnection(config: SessionConfig) = + RemoteConnection.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(RemoteConnection.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() + + new (?host, ?port, ?blocking, ?timeout) = + new RemoteConnection(getConnection host port blocking timeout) + + 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.toHandle value = + let handleName = getNextSymbolName() + let rName, rValue = toR value + this.assign handleName rValue + + 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 : obj) = + let symbolName, se = toR value + eval(sprintf "evalServer(%s, %s, %s)" this.connectionName name symbolName) |> ignore + new RemoteSymbolicExpression(this.getHandleValue, name) + + 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 |> ignore + 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 RemoteSession (remoteConnection : RemoteConnection) as x = + new (?host, ?port, ?blocking, ?timeout) = + new RemoteSession(new RemoteConnection(?host=host, ?port=port, ?blocking=blocking, ?timeout=timeout)) + + new (config : SessionConfig) = + new RemoteSession(RemoteConnection.GetConnection(config)) + + member x.Connection = remoteConnection + + static member (?<-) (session : RemoteSession, name : string, value) = + session.Connection.assign name value + + static member (?) (session : RemoteSession, name : string) = + session.Connection.evalToHandle name + +[] +type RemoteSessionUtil = + [] + static member ToLocalValue (value : obj) = + toR value + + [] + static member ToLocalValue (value : RemoteSymbolicExpression) = + value.GetValue() + + [] + static member ToRemoteValue (value : obj, session : RemoteSession) = + session.Connection.toHandle value diff --git a/tests/Test.RProvider/Test.RProvider.fsproj b/tests/Test.RProvider/Test.RProvider.fsproj index 78229c27..bec37e20 100644 --- a/tests/Test.RProvider/Test.RProvider.fsproj +++ b/tests/Test.RProvider/Test.RProvider.fsproj @@ -49,6 +49,7 @@ + diff --git a/tests/Test.RProvider/Test.fs b/tests/Test.RProvider/Test.fs index 31387f78..9242b365 100644 --- a/tests/Test.RProvider/Test.fs +++ b/tests/Test.RProvider/Test.fs @@ -137,3 +137,19 @@ let ``String arrays round-trip via factors`` () = [] let ``String arrays round-trip via DataFrame`` () = roundTripAsDataframe [| "foo"; "bar"; "foo"; "bar" |] + +(* +let validateTypeProviderExtensionMethods () = + // The RemoteRTypeProvider should generate extension methods for RemoteSession + // This function would merely prove that it can be compiled + let rr = RemoteSession.GetConnection() + + // This method should be generated by RemoteRTypeProvider + RemoteR.c(rr, 1, 2, 3) |> ignore + + // The method should also be an extension method on the RemoteSession type. + // If extension methods aren't supported by the compiler, then this line will + // result in a compiler error. + rr.c(1,2,3) |> ignore +*) +