├── Tests ├── S4ClassTests.pas ├── MiscellaneousTests.pas ├── opaRTests.dpr ├── EvaluateTests.pas ├── IntegerVectorTests.pas ├── NumericVectorTests.pas ├── EnvironmentTests.pas ├── ListTests.pas ├── CharacterVectorTests.pas ├── DataFrameTests.pas ├── S4Test.pas ├── ErrorHandlingTests.pas ├── UnivariateStatsTests.pas ├── MatrixTests.pas ├── opaR.TestUtils.pas └── FactorTests.pas ├── Src ├── opaR.ComplexMatrix.pas ├── opaR.ComplexVector.pas ├── opaR.Internals.Windows.RStart.pas ├── opaR.Language.pas ├── opaR.Internals.Unix.RStart.pas ├── opaR.Internals.Windows.Delegates.pas ├── opaR.VectorUtils.pas ├── opaR.VECTOR_SEXPREC.pas ├── opaR.Exception.pas ├── opaR.SpecialFunction.pas ├── opaR.BuiltInFunction.pas ├── opaR.SEXPREC.pas ├── opaR.InternalString.pas ├── opaR.ProtectedPointer.pas ├── opaR.Expression.pas ├── opaR.Symbol.pas ├── opaR.Closure.pas ├── opaR.DataFrameRow.pas ├── opaR.ExpressionVector.pas ├── opaR.LogicalMatrix.pas ├── opaR.IntegerMatrix.pas ├── opaR.Environment.pas ├── opaR.LogicalVector.pas ├── opaR.NumericMatrix.pas ├── opaR.Factor.pas ├── opaR.PairList.pas ├── opaR.RawVector.pas ├── opaR.CharacterMatrix.pas ├── Devices │ ├── opaR.Devices.NullCharacterDevice.pas │ ├── opaR.Devices.ConsoleDevice.pas │ └── opaR.Devices.CharacterDeviceAdapter.pas ├── opaR.Utils.pas ├── opaR.S4Object.pas ├── opaR.RFunction.pas ├── opaR.NumericVector.pas ├── opaR.IntegerVector.pas └── opaR.GenericVector.pas └── Readme.md /Tests/S4ClassTests.pas: -------------------------------------------------------------------------------- 1 | unit S4ClassTests; 2 | 3 | interface 4 | 5 | implementation 6 | 7 | end. 8 | -------------------------------------------------------------------------------- /Src/opaR.ComplexMatrix.pas: -------------------------------------------------------------------------------- 1 | unit opaR.ComplexMatrix; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | { TODO : ComplexMatrix } 25 | 26 | implementation 27 | 28 | end. 29 | -------------------------------------------------------------------------------- /Src/opaR.ComplexVector.pas: -------------------------------------------------------------------------------- 1 | unit opaR.ComplexVector; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | { TODO : ComplexVector } 25 | 26 | implementation 27 | 28 | end. 29 | -------------------------------------------------------------------------------- /Tests/MiscellaneousTests.pas: -------------------------------------------------------------------------------- 1 | unit MiscellaneousTests; 2 | 3 | interface 4 | 5 | uses 6 | TestFramework, 7 | 8 | opaR.Engine, 9 | opaR.InternalString, 10 | opaR.Interfaces; 11 | 12 | type 13 | TMiscellaneousTests = class(TTestCase) 14 | private 15 | FEngine: IREngine; 16 | protected 17 | procedure SetUp; override; 18 | procedure TearDown; override; 19 | published 20 | procedure InternalString_Test; 21 | end; 22 | 23 | implementation 24 | 25 | { TInternalStringTests } 26 | 27 | //------------------------------------------------------------------------------ 28 | procedure TMiscellaneousTests.InternalString_Test; 29 | var 30 | expr: IInternalString; 31 | begin 32 | expr := TInternalString.Create(FEngine, 'abc'); 33 | CheckEquals('abc', expr.ToString); 34 | end; 35 | //------------------------------------------------------------------------------ 36 | procedure TMiscellaneousTests.SetUp; 37 | begin 38 | TREngine.SetEnvironmentVariables; 39 | FEngine := TREngine.GetInstance; 40 | end; 41 | //------------------------------------------------------------------------------ 42 | procedure TMiscellaneousTests.TearDown; 43 | begin 44 | inherited; 45 | 46 | end; 47 | 48 | 49 | 50 | initialization 51 | TestFramework.RegisterTest(TMiscellaneousTests.Suite); 52 | 53 | end. 54 | -------------------------------------------------------------------------------- /Tests/opaRTests.dpr: -------------------------------------------------------------------------------- 1 | program opaRTests; 2 | { 3 | 4 | Delphi DUnit Test Project 5 | ------------------------- 6 | This project contains the DUnit test framework and the GUI/Console test runners. 7 | Add "CONSOLE_TESTRUNNER" to the conditional defines entry in the project options 8 | to use the console test runner. Otherwise the GUI test runner will be used by 9 | default. 10 | 11 | } 12 | 13 | {$IFDEF CONSOLE_TESTRUNNER} 14 | {$APPTYPE CONSOLE} 15 | {$ENDIF} 16 | 17 | uses 18 | FastMM4, 19 | DUnitTestRunner, 20 | NumericVectorTests in 'NumericVectorTests.pas', 21 | IntegerVectorTests in 'IntegerVectorTests.pas', 22 | MiscellaneousTests in 'MiscellaneousTests.pas', 23 | EnvironmentTests in 'EnvironmentTests.pas', 24 | CharacterVectorTests in 'CharacterVectorTests.pas', 25 | ErrorHandlingTests in 'ErrorHandlingTests.pas', 26 | UnivariateStatsTests in 'UnivariateStatsTests.pas', 27 | DataFrameTests in 'DataFrameTests.pas', 28 | MatrixTests in 'MatrixTests.pas', 29 | EvaluateTests in 'EvaluateTests.pas', 30 | opaR.TestUtils in 'opaR.TestUtils.pas', 31 | FactorTests in 'FactorTests.pas', 32 | ListTests in 'ListTests.pas', 33 | RFunctionTests in 'RFunctionTests.pas', 34 | S4ClassTests in 'S4ClassTests.pas', 35 | S4Test in 'S4Test.pas'; 36 | 37 | {$R *.RES} 38 | 39 | begin 40 | ReportMemoryLeaksOnShutdown := True; 41 | 42 | DUnitTestRunner.RunRegisteredTests; 43 | end. 44 | 45 | -------------------------------------------------------------------------------- /Tests/EvaluateTests.pas: -------------------------------------------------------------------------------- 1 | unit EvaluateTests; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | This group of tests covers the use of "Evaluate" for a number of different 6 | input scripts. 7 | 8 | -------------------------------------------------------------------------------} 9 | 10 | interface 11 | 12 | uses 13 | System.Math, 14 | TestFramework, 15 | 16 | opaR.Engine, 17 | opaR.SymbolicExpression, 18 | opaR.Interfaces; 19 | 20 | type 21 | TEvaluateTests = class(TTestCase) 22 | private 23 | FEngine: IREngine; 24 | protected 25 | procedure SetUp; override; 26 | procedure TearDown; override; 27 | published 28 | procedure Eval_Test1; 29 | end; 30 | 31 | implementation 32 | 33 | { TEvaluateTests } 34 | 35 | //------------------------------------------------------------------------------ 36 | procedure TEvaluateTests.Eval_Test1; 37 | begin 38 | 39 | end; 40 | //------------------------------------------------------------------------------ 41 | procedure TEvaluateTests.SetUp; 42 | begin 43 | TREngine.SetEnvironmentVariables; 44 | FEngine := TREngine.GetInstance; 45 | end; 46 | //------------------------------------------------------------------------------ 47 | procedure TEvaluateTests.TearDown; 48 | begin 49 | inherited; 50 | 51 | end; 52 | 53 | 54 | initialization 55 | TestFramework.RegisterTest(TEvaluateTests.Suite); 56 | 57 | end. 58 | -------------------------------------------------------------------------------- /Src/opaR.Internals.Windows.RStart.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Internals.Windows.RStart; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | opaR.Utils, 26 | opaR.Internals.Unix.RStart, 27 | opaR.Internals.Windows.Delegates; 28 | 29 | type 30 | TUnixRStruct = opaR.Internals.Unix.RStart.TRStart; 31 | 32 | TRStart = {packed} record 33 | Common: TUnixRStruct; 34 | rhome: PAnsiChar; 35 | home: PAnsiChar; 36 | 37 | ReadConsole: Tblah1; 38 | WriteConsole: Tblah2; 39 | CallBack: Tblah3; 40 | ShowMessage: Tblah4; 41 | YesNoCancel: Tblah5; 42 | Busy: Tblah6; 43 | CharacterMode: TUiMode; 44 | WriteConsoleEx: Tblah7; 45 | end; 46 | 47 | implementation 48 | 49 | end. 50 | -------------------------------------------------------------------------------- /Src/opaR.Language.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Language; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | opaR.SEXPREC, 26 | opaR.DLLFunctions, 27 | opaR.SymbolicExpression, 28 | opaR.Pairlist, 29 | opaR.Interfaces; 30 | 31 | type 32 | TRLanguage = class(TSymbolicExpression, IRLanguage) 33 | public 34 | function FunctionCall: IPairList; 35 | end; 36 | 37 | 38 | implementation 39 | 40 | { TRLanguage } 41 | 42 | //------------------------------------------------------------------------------ 43 | function TRLanguage.FunctionCall: IPairList; 44 | var 45 | pairCount: integer; 46 | sexp: TSEXPREC; 47 | begin 48 | pairCount := Engine.Rapi.Length(Handle); 49 | 50 | if pairCount < 2 then 51 | result := nil 52 | else 53 | begin 54 | sexp := GetInternalStructure; 55 | result := TPairList.Create(Engine, sexp.listsxp.cdrval); 56 | end; 57 | end; 58 | 59 | end. 60 | -------------------------------------------------------------------------------- /Src/opaR.Internals.Unix.RStart.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Internals.Unix.RStart; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | Note the use of LongBool for compatibility with the R DLL. 25 | 26 | -------------------------------------------------------------------------------} 27 | 28 | 29 | interface 30 | 31 | uses 32 | opaR.Utils; 33 | 34 | type 35 | TRStart = {packed} record // -- Use of "packed" causes an AV on Windows x64 36 | R_Quiet: LongBool; 37 | R_Slave: LongBool; 38 | R_Interactive: LongBool; 39 | R_Verbose: LongBool; 40 | LoadSiteFile: LongBool; 41 | LoadInitFile: LongBool; 42 | DebugInitFile: LongBool; 43 | RestoreAction: TStartupRestoreAction; 44 | SaveAction: TStartupSaveAction; 45 | vsize: NativeUInt; 46 | nsize: NativeUInt; 47 | max_vsize: NativeUInt; 48 | max_nsize: NativeUInt; 49 | ppsize: NativeUInt; 50 | NoRenviron: LongBool; 51 | end; 52 | 53 | implementation 54 | 55 | end. 56 | -------------------------------------------------------------------------------- /Src/opaR.Internals.Windows.Delegates.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Internals.Windows.Delegates; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | Note that we've used the .NET "Delegates" terminology here. 25 | 26 | -------------------------------------------------------------------------------} 27 | 28 | interface 29 | 30 | uses 31 | opaR.Utils; 32 | 33 | type 34 | // -- PAnsiChar type is used for UnmanagedType.LPStr. Note that the buffer 35 | // -- param is a StringBuilder in RDotNet, while prompt is a string. 36 | Tblah1 = function(prompt, buffer: PAnsiChar; length: integer; history: LongBool): LongBool; cdecl; 37 | Tblah2 = procedure(const buffer: PAnsiChar; length: integer); cdecl; 38 | Tblah3 = procedure; cdecl; 39 | Tblah4 = procedure(const msg: PAnsiChar); cdecl; 40 | Tblah5 = function(const question: PAnsiChar): TYesNoCancel; cdecl; 41 | Tblah6 = procedure(which: TBusyType); cdecl; 42 | Tblah7 = procedure(const buffer: PAnsiChar; length: integer; outputType: TConsoleOutputType); cdecl; 43 | 44 | implementation 45 | 46 | end. 47 | -------------------------------------------------------------------------------- /Src/opaR.VectorUtils.pas: -------------------------------------------------------------------------------- 1 | unit opaR.VectorUtils; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | Define our own generic interfaces - don't bother with the non-generic ones. 25 | 26 | Note that our generic interfaces should not have GUIDs. 27 | 28 | -------------------------------------------------------------------------------} 29 | 30 | interface 31 | 32 | uses 33 | System.Types, 34 | 35 | opaR.SEXPREC; 36 | 37 | type 38 | //IVectorEnumerator = interface 39 | // ['{B38F0A35-FCF4-48C9-8C19-ED7DC584E6A1}'] 40 | // function GetCurrent: Pointer; 41 | // function MoveNext: Boolean; 42 | // property Current: Pointer read GetCurrent; 43 | //end; 44 | 45 | IVectorEnumerator = interface{(IVectorEnumerator)} 46 | function GetCurrent: T; 47 | function MoveNext: Boolean; 48 | property Current: T read GetCurrent; 49 | end; 50 | 51 | // -- Define our own IEnumerable which doesn't depend on the non-generic version. 52 | IVectorEnumerable = interface 53 | function GetEnumerator: IVectorEnumerator; 54 | end; 55 | 56 | 57 | implementation 58 | 59 | 60 | 61 | 62 | 63 | end. 64 | -------------------------------------------------------------------------------- /Src/opaR.VECTOR_SEXPREC.pas: -------------------------------------------------------------------------------- 1 | unit opaR.VECTOR_SEXPREC; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | VECTOR_SEXPREC is a reduced version of SEXPREC used as a header in vector nodes. 25 | Note that it must be kept in sync with SEXPREC. 26 | 27 | -------------------------------------------------------------------------------} 28 | 29 | interface 30 | 31 | uses 32 | opaR.Utils, 33 | opaR.SEXPREC; 34 | 35 | type 36 | TVECTOR_SEXPREC = packed record 37 | private 38 | function GetLength: integer; 39 | function GetTrueLength: integer; 40 | public 41 | sxpinfo: Tsxpinfo; 42 | attrib: PSEXPREC; 43 | gengc_next_node: PSEXPREC; 44 | gengc_prev_node: PSEXPREC; 45 | vecsxp: Tvecsxp; 46 | property Length: integer read GetLength; 47 | property TrueLength: integer read GetTrueLength; 48 | end; 49 | 50 | implementation 51 | 52 | 53 | { TVECTOR_SEXPREC } 54 | 55 | //------------------------------------------------------------------------------ 56 | function TVECTOR_SEXPREC.GetLength: integer; 57 | begin 58 | result := vecsxp.length; 59 | end; 60 | //------------------------------------------------------------------------------ 61 | function TVECTOR_SEXPREC.GetTrueLength: integer; 62 | begin 63 | result := vecsxp.truelength; 64 | end; 65 | 66 | end. 67 | -------------------------------------------------------------------------------- /Src/opaR.Exception.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Exception; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | System.SysUtils, 26 | System.TypInfo, 27 | 28 | opaR.Utils; 29 | 30 | type 31 | EopaRParseException = class(EopaRException) 32 | private 33 | FStatus: TParseStatus; 34 | FErrorStatement: string; 35 | public 36 | constructor Create(status: TParseStatus; errorStatement, errorMsg: string); 37 | property ErrorStatement: string read FErrorStatement; 38 | property Status: TParseStatus read FStatus; 39 | end; 40 | 41 | EopaREvaluationException = class(EopaRException) 42 | public 43 | constructor Create(errorMsg: string); 44 | end; 45 | 46 | implementation 47 | 48 | 49 | { TopaRParseException } 50 | 51 | //------------------------------------------------------------------------------ 52 | constructor EopaRParseException.Create(status: TParseStatus; errorStatement, 53 | errorMsg: string); 54 | begin 55 | inherited CreateFmt('Status %s for %s : %s', [GetEnumName(TypeInfo(TParseStatus), Ord(status)), errorStatement, errorMsg]); 56 | end; 57 | 58 | 59 | { EopaREvaluationException } 60 | 61 | //------------------------------------------------------------------------------ 62 | constructor EopaREvaluationException.Create(errorMsg: string); 63 | begin 64 | inherited CreateFmt('%s', [errorMsg]); 65 | end; 66 | 67 | end. 68 | -------------------------------------------------------------------------------- /Src/opaR.SpecialFunction.pas: -------------------------------------------------------------------------------- 1 | unit opaR.SpecialFunction; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | opaR.Interfaces, 26 | opaR.RFunction; 27 | 28 | type 29 | TRSpecialFunction = class(TRFunction) 30 | public 31 | function Invoke: ISymbolicExpression; overload; override; 32 | function Invoke(arg: ISymbolicExpression): ISymbolicExpression; overload; override; 33 | function Invoke(args: TArray): ISymbolicExpression; overload; override; 34 | end; 35 | 36 | implementation 37 | 38 | uses 39 | opaR.EngineExtension; 40 | 41 | { TRSpecialFunction } 42 | 43 | //------------------------------------------------------------------------------ 44 | function TRSpecialFunction.Invoke( 45 | args: TArray): ISymbolicExpression; 46 | begin 47 | result := InvokeOrderedArguments(args); 48 | end; 49 | //------------------------------------------------------------------------------ 50 | function TRSpecialFunction.Invoke( 51 | arg: ISymbolicExpression): ISymbolicExpression; 52 | var 53 | arr: TArray; 54 | begin 55 | arr := TArray.Create(arg); 56 | result := Invoke(arr); 57 | end; 58 | //------------------------------------------------------------------------------ 59 | function TRSpecialFunction.Invoke: ISymbolicExpression; 60 | begin 61 | result := CreateCallAndEvaluate(TEngineExtension(Engine).NilValue); 62 | end; 63 | 64 | end. 65 | -------------------------------------------------------------------------------- /Src/opaR.BuiltInFunction.pas: -------------------------------------------------------------------------------- 1 | unit opaR.BuiltInFunction; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | opaR.SymbolicExpression, 26 | opaR.Interfaces, 27 | opaR.RFunction; 28 | 29 | type 30 | TRBuiltInFunction = class(TRFunction) 31 | public 32 | function Invoke: ISymbolicExpression; overload; override; 33 | function Invoke(arg: ISymbolicExpression): ISymbolicExpression; overload; override; 34 | function Invoke(args: TArray): ISymbolicExpression; overload; override; 35 | end; 36 | 37 | implementation 38 | 39 | uses 40 | opaR.EngineExtension; 41 | 42 | { TRBuiltInFunction } 43 | 44 | //------------------------------------------------------------------------------ 45 | function TRBuiltInFunction.Invoke( 46 | args: TArray): ISymbolicExpression; 47 | begin 48 | result := InvokeOrderedArguments(args); 49 | end; 50 | //------------------------------------------------------------------------------ 51 | function TRBuiltInFunction.Invoke( 52 | arg: ISymbolicExpression): ISymbolicExpression; 53 | var 54 | arr: TArray; 55 | begin 56 | arr := TArray.Create(arg); 57 | result := Invoke(arr); 58 | end; 59 | //------------------------------------------------------------------------------ 60 | function TRBuiltInFunction.Invoke: ISymbolicExpression; 61 | begin 62 | result := CreateCallAndEvaluate(TEngineExtension(Engine).NilValue); 63 | end; 64 | 65 | end. 66 | -------------------------------------------------------------------------------- /Src/opaR.SEXPREC.pas: -------------------------------------------------------------------------------- 1 | unit opaR.SEXPREC; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | opaR.Utils; 26 | 27 | type 28 | PSEXPREC = ^TSEXPREC; 29 | TPSEXPRECArray = array of PSEXPREC; 30 | 31 | Tvecsxp = packed record 32 | length: integer; 33 | truelength: integer; 34 | end; 35 | 36 | Tprimsxp = packed record 37 | offset: integer; 38 | end; 39 | 40 | Tsymsxp = packed record 41 | pname: PSEXPREC; 42 | value: PSEXPREC; 43 | internal: PSEXPREC; 44 | end; 45 | 46 | Tlistsxp = packed record 47 | carval: PSEXPREC; 48 | cdrval: PSEXPREC; 49 | tagval: PSEXPREC; 50 | end; 51 | 52 | Tenvsxp = packed record 53 | frame: PSEXPREC; 54 | enclos: PSEXPREC; 55 | hashtab: PSEXPREC; 56 | end; 57 | 58 | Tclosxp = packed record 59 | formals: PSEXPREC; 60 | body: PSEXPREC; 61 | env: PSEXPREC; 62 | end; 63 | 64 | Tpromsxp = packed record 65 | value: PSEXPREC; 66 | expr: PSEXPREC; 67 | env: PSEXPREC; 68 | end; 69 | 70 | 71 | // -- TSEXP includes a union in the C definition - see the following article for 72 | // -- conversion: http://praxis-velthuis.de/rdc/articles/articles-convert.html#unions 73 | TSEXPREC = packed record 74 | sxpinfo: Tsxpinfo; 75 | attrib: PSEXPREC; 76 | gengc_next_node: PSEXPREC; 77 | gengc_prev_node: PSEXPREC; 78 | 79 | // -- Translation of the union member "u". 80 | case integer of 81 | 1: (primsxp: Tprimsxp); 82 | 2: (symsxp: Tsymsxp); 83 | 3: (listsxp: Tlistsxp); 84 | 4: (envsxp: Tenvsxp); 85 | 5: (closxp: Tclosxp); 86 | 6: (promsxp: Tpromsxp); 87 | end; 88 | 89 | 90 | 91 | 92 | implementation 93 | 94 | end. 95 | -------------------------------------------------------------------------------- /Src/opaR.InternalString.pas: -------------------------------------------------------------------------------- 1 | unit opaR.InternalString; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | The R.NET version of InternalString includes: 25 | 1. Implicit cast for the string (operator overloading not available in Delphi/Win) 26 | 2. GetInternalValue - returns null 27 | 28 | Since there's no "null" for Delphi strings just implement ToString. 29 | 30 | -------------------------------------------------------------------------------} 31 | 32 | 33 | interface 34 | 35 | uses 36 | opaR.VECTOR_SEXPREC, 37 | opaR.SEXPREC, 38 | opaR.SymbolicExpression, 39 | opaR.Interfaces, 40 | opaR.DLLFunctions; 41 | 42 | 43 | type 44 | TInternalString = class(TSymbolicExpression, IInternalString) 45 | public 46 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); overload; 47 | constructor Create(const engine: IREngine; s: string); overload; 48 | function ToString: string; override; 49 | end; 50 | 51 | implementation 52 | 53 | { TInternalString } 54 | 55 | //------------------------------------------------------------------------------ 56 | constructor TInternalString.Create(const engine: IREngine; pExpr: PSEXPREC); 57 | begin 58 | inherited Create(engine, pExpr); 59 | end; 60 | //------------------------------------------------------------------------------ 61 | constructor TInternalString.Create(const engine: IREngine; s: string); 62 | var 63 | pExpr: PSEXPREC; 64 | begin 65 | pExpr := Engine.Rapi.MakeChar(PAnsiChar(AnsiString(s))); 66 | 67 | inherited Create(engine, pExpr); 68 | end; 69 | //------------------------------------------------------------------------------ 70 | function TInternalString.ToString: string; 71 | begin 72 | result := String(AnsiString(PAnsiChar(NativeUInt(Handle) + SizeOf(TVECTOR_SEXPREC)))); 73 | end; 74 | 75 | end. 76 | -------------------------------------------------------------------------------- /Src/opaR.ProtectedPointer.pas: -------------------------------------------------------------------------------- 1 | unit opaR.ProtectedPointer; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | TProtectedPointer acts as a wrapper around a SEXPREC, preventing it being 25 | destroyed by the R garbage collector. 26 | 27 | -------------------------------------------------------------------------------} 28 | 29 | 30 | interface 31 | 32 | uses 33 | opaR.SEXPREC, 34 | opaR.Utils, 35 | opaR.DLLFunctions, 36 | opaR.Interfaces; 37 | 38 | type 39 | TProtectedPointer = class 40 | private 41 | FEngineHandle: HMODULE; 42 | FHandle: PSEXPREC; 43 | FEngine: IREngine; 44 | public 45 | constructor Create(sexp: ISymbolicExpression); overload; 46 | constructor Create(const engine: IREngine; p: PSEXPREC); overload; 47 | destructor Destroy; override; 48 | end; 49 | 50 | implementation 51 | 52 | 53 | { TProtectedPointer } 54 | 55 | //------------------------------------------------------------------------------ 56 | constructor TProtectedPointer.Create(const engine: IREngine; p: PSEXPREC); 57 | begin 58 | FHandle := p; 59 | FEngineHandle := engine.Handle; 60 | FEngine := engine; 61 | 62 | if FEngineHandle = 0 then 63 | raise EopaRException.Create('Null engine handle in ProtectedPointer constructor'); 64 | 65 | engine.Rapi.Protect(FHandle); 66 | end; 67 | //------------------------------------------------------------------------------ 68 | constructor TProtectedPointer.Create(sexp: ISymbolicExpression); 69 | begin 70 | FHandle := sexp.Handle; 71 | FEngineHandle := sexp.EngineHandle; 72 | FEngine := sexp.Engine; 73 | 74 | sexp.Engine.Rapi.Protect(FHandle); 75 | end; 76 | //------------------------------------------------------------------------------ 77 | destructor TProtectedPointer.Destroy; 78 | begin 79 | FEngine.Rapi.Unprotect(FHandle); 80 | inherited; 81 | end; 82 | 83 | 84 | end. 85 | -------------------------------------------------------------------------------- /Tests/IntegerVectorTests.pas: -------------------------------------------------------------------------------- 1 | unit IntegerVectorTests; 2 | 3 | interface 4 | 5 | uses 6 | TestFramework, 7 | 8 | opaR.Engine, 9 | opaR.Interfaces, 10 | opaR.SymbolicExpression, 11 | opaR.IntegerVector; 12 | 13 | type 14 | TIntegerVectorTests = class(TTestCase) 15 | private 16 | FEngine: IREngine; 17 | protected 18 | procedure SetUp; override; 19 | procedure TearDown; override; 20 | published 21 | procedure IntegerVector_ArrayInitialisation_Test; 22 | procedure IntegerVector_ToArray_Test; 23 | procedure IntegerVector_SetVectorDirect_Test; 24 | end; 25 | 26 | 27 | implementation 28 | 29 | { TIntegerVectorTests } 30 | 31 | //------------------------------------------------------------------------------ 32 | procedure TIntegerVectorTests.IntegerVector_ArrayInitialisation_Test; 33 | var 34 | arr: TArray; 35 | vec: IIntegerVector; 36 | begin 37 | arr := TArray.Create(10, 20, 30, 40, 50); 38 | vec := TIntegerVector.Create(FEngine, arr); 39 | 40 | CheckEquals(true, (vec as TSymbolicExpression).IsVector); 41 | CheckEquals(5, vec.VectorLength); 42 | CheckEquals(20, vec[1]); 43 | CheckEquals(50, vec[4]); 44 | end; 45 | //------------------------------------------------------------------------------ 46 | procedure TIntegerVectorTests.IntegerVector_SetVectorDirect_Test; 47 | var 48 | arr: TArray; 49 | vec: IIntegerVector; 50 | begin 51 | arr := TArray.Create(10, 20, 30, 40, 50); 52 | vec := TIntegerVector.Create(FEngine, Length(arr)); 53 | vec.SetVectorDirect(arr); 54 | 55 | CheckEquals(true, (vec as TSymbolicExpression).IsVector); 56 | CheckEquals(5, vec.VectorLength); 57 | CheckEquals(20, vec[1]); 58 | CheckEquals(50, vec[4]); 59 | end; 60 | //------------------------------------------------------------------------------ 61 | procedure TIntegerVectorTests.IntegerVector_ToArray_Test; 62 | var 63 | arr1: TArray; 64 | arr2: TArray; 65 | vec: IIntegerVector; 66 | begin 67 | arr1 := TArray.Create(10, 20, 30, 40, 50); 68 | vec := TIntegerVector.Create(FEngine, arr1); 69 | 70 | CheckEquals(true, (vec as TSymbolicExpression).IsVector); 71 | arr2 := vec.ToArray; 72 | 73 | CheckEquals(20, arr2[1]); 74 | CheckEquals(50, arr2[4]); 75 | end; 76 | //------------------------------------------------------------------------------ 77 | procedure TIntegerVectorTests.SetUp; 78 | begin 79 | TREngine.SetEnvironmentVariables; 80 | FEngine := TREngine.GetInstance; 81 | end; 82 | //------------------------------------------------------------------------------ 83 | procedure TIntegerVectorTests.TearDown; 84 | begin 85 | inherited; 86 | 87 | end; 88 | 89 | 90 | 91 | initialization 92 | TestFramework.RegisterTest(TIntegerVectorTests.Suite); 93 | 94 | end. 95 | -------------------------------------------------------------------------------- /Tests/NumericVectorTests.pas: -------------------------------------------------------------------------------- 1 | unit NumericVectorTests; 2 | 3 | interface 4 | 5 | uses 6 | TestFramework, 7 | System.Math, 8 | 9 | opaR.Interfaces, 10 | opaR.Engine, 11 | opaR.SymbolicExpression, 12 | opaR.NumericVector; 13 | 14 | 15 | type 16 | TNumericVectorTests = class(TTestCase) 17 | private 18 | FEngine: IREngine; 19 | protected 20 | procedure SetUp; override; 21 | procedure TearDown; override; 22 | published 23 | procedure NumericVector_ArrayInitialisation_Test; 24 | procedure NumericVector_ToArray_Test; 25 | procedure NumericVector_SetVectorDirect_Test; 26 | end; 27 | 28 | implementation 29 | 30 | 31 | { TNumericVectorTests } 32 | 33 | //------------------------------------------------------------------------------ 34 | procedure TNumericVectorTests.NumericVector_ArrayInitialisation_Test; 35 | var 36 | arr: TArray; 37 | vec: INumericVector; 38 | begin 39 | arr := TArray.Create(1.1, 2.2, 3.3, 4.4, 5.5); 40 | vec := TNumericVector.Create(FEngine, arr); 41 | 42 | CheckEquals(true, (vec as TSymbolicExpression).IsVector); 43 | CheckEquals(5, vec.VectorLength); 44 | Check(SameValue(2.2, vec[1])); 45 | Check(SameValue(5.5, vec[4])); 46 | end; 47 | //------------------------------------------------------------------------------ 48 | procedure TNumericVectorTests.NumericVector_ToArray_Test; 49 | var 50 | arr1: TArray; 51 | arr2: TArray; 52 | vec: INumericVector; 53 | begin 54 | arr1 := TArray.Create(1.1, 2.2, 3.3, 4.4, 5.5); 55 | vec := TNumericVector.Create(FEngine, arr1); 56 | 57 | CheckEquals(true, (vec as TSymbolicExpression).IsVector); 58 | arr2 := vec.ToArray; 59 | 60 | Check(SameValue(2.2, arr2[1])); 61 | Check(SameValue(5.5, arr2[4])); 62 | end; 63 | //------------------------------------------------------------------------------ 64 | procedure TNumericVectorTests.NumericVector_SetVectorDirect_Test; 65 | var 66 | arr: TArray; 67 | vec: INumericVector; 68 | begin 69 | arr := TArray.Create(1.1, 2.2, 3.3, 4.4, 5.5); 70 | vec := TNumericVector.Create(FEngine, Length(arr)); 71 | vec.SetVectorDirect(arr); 72 | 73 | CheckEquals(true, (vec as TSymbolicExpression).IsVector); 74 | CheckEquals(5, vec.VectorLength); 75 | Check(SameValue(2.2, vec[1])); 76 | Check(SameValue(5.5, vec[4])); 77 | end; 78 | //------------------------------------------------------------------------------ 79 | procedure TNumericVectorTests.SetUp; 80 | begin 81 | TREngine.SetEnvironmentVariables; 82 | FEngine := TREngine.GetInstance; 83 | end; 84 | //------------------------------------------------------------------------------ 85 | procedure TNumericVectorTests.TearDown; 86 | begin 87 | inherited; 88 | 89 | end; 90 | 91 | 92 | initialization 93 | TestFramework.RegisterTest(TNumericVectorTests.Suite); 94 | 95 | end. 96 | -------------------------------------------------------------------------------- /Tests/EnvironmentTests.pas: -------------------------------------------------------------------------------- 1 | unit EnvironmentTests; 2 | 3 | interface 4 | 5 | uses 6 | TestFramework, 7 | 8 | opaR.Engine, 9 | opaR.Environment, 10 | opaR.NumericVector, 11 | opaR.Interfaces; 12 | 13 | type 14 | TEnvironmentTests = class(TTestCase) 15 | private 16 | FEngine: IREngine; 17 | protected 18 | procedure SetUp; override; 19 | procedure TearDown; override; 20 | published 21 | procedure GlobalEnvironment_Test; 22 | procedure NewEnvironment_Test; 23 | end; 24 | 25 | 26 | implementation 27 | 28 | { TEnvironmentTests } 29 | 30 | //------------------------------------------------------------------------------ 31 | procedure TEnvironmentTests.GlobalEnvironment_Test; 32 | var 33 | globalEnv: IREnvironment; 34 | arrSymbolNames: TArray; 35 | i: integer; 36 | arr1: TArray; 37 | vec: INumericVector; 38 | begin 39 | // -- In this test we add some symbols to the global environment and check 40 | // -- that we can retrieve them. 41 | globalEnv := FEngine.GlobalEnvironment; 42 | 43 | arr1 := TArray.Create(1.0, 2.0, 3.0, 4.0, 5.0); 44 | vec := TNumericVector.Create(FEngine, arr1); 45 | globalEnv.SetSymbol('vec1', (vec as ISymbolicExpression)); 46 | 47 | FEngine.Evaluate('x <- 3'); 48 | FEngine.Evaluate('y <- 4'); 49 | 50 | arrSymbolNames := globalEnv.GetSymbolNames(false); 51 | 52 | CheckEquals(3, Length(arrSymbolNames)); 53 | CheckEquals('vec1', arrSymbolNames[0]); 54 | CheckEquals('x', arrSymbolNames[1]); 55 | CheckEquals('y', arrSymbolNames[2]); 56 | end; 57 | //------------------------------------------------------------------------------ 58 | procedure TEnvironmentTests.NewEnvironment_Test; 59 | var 60 | globalEnv: IREnvironment; 61 | newEnv: IREnvironment; 62 | arrSymbolNames: TArray; 63 | begin 64 | globalEnv := FEngine.GlobalEnvironment; 65 | 66 | // -- Create a new environment (with the global as it's parent), name it and 67 | // -- add a couple of variables to it. 68 | newEnv := TREnvironment.Create(FEngine, globalEnv); 69 | globalEnv.SetSymbol('e', newEnv); 70 | 71 | // -- Note that we qualify the variable names with the new env name. 72 | FEngine.Evaluate('e$x <- 3'); 73 | FEngine.Evaluate('e$y <- 4'); 74 | 75 | arrSymbolNames := newEnv.GetSymbolNames(false); 76 | 77 | CheckEquals(2, Length(arrSymbolNames)); 78 | CheckEquals('x', arrSymbolNames[0]); 79 | CheckEquals('y', arrSymbolNames[1]); 80 | end; 81 | //------------------------------------------------------------------------------ 82 | procedure TEnvironmentTests.SetUp; 83 | begin 84 | TREngine.SetEnvironmentVariables; 85 | FEngine := TREngine.GetInstance; 86 | end; 87 | //------------------------------------------------------------------------------ 88 | procedure TEnvironmentTests.TearDown; 89 | begin 90 | inherited; 91 | 92 | end; 93 | 94 | 95 | initialization 96 | TestFramework.RegisterTest(TEnvironmentTests.Suite); 97 | 98 | end. 99 | -------------------------------------------------------------------------------- /Tests/ListTests.pas: -------------------------------------------------------------------------------- 1 | unit ListTests; 2 | 3 | interface 4 | 5 | uses 6 | System.Math, 7 | TestFramework, 8 | 9 | opaR.TestUtils, 10 | 11 | opaR.Engine, 12 | opaR.SymbolicExpression, 13 | opaR.Interfaces, 14 | opaR.Exception; 15 | 16 | 17 | type 18 | TListTests = class(TTestCase) 19 | private 20 | FEngine: IREngine; 21 | protected 22 | procedure SetUp; override; 23 | procedure TearDown; override; 24 | published 25 | procedure CoercionAsList_Test; 26 | procedure IsList_Test; 27 | procedure ListSubsetting_Test; 28 | end; 29 | 30 | implementation 31 | 32 | { TListTests } 33 | 34 | //------------------------------------------------------------------------------ 35 | procedure TListTests.CoercionAsList_Test; 36 | var 37 | functionAsList: IGenericVector; 38 | dataFrame: ISymbolicExpression; 39 | dataFrameAsList: IGenericVector; 40 | begin 41 | functionAsList := FEngine.Evaluate('as.list').AsList; 42 | CheckEquals(3, functionAsList.VectorLength); 43 | CheckEquals(true, functionAsList[0].IsSymbol); 44 | CheckEquals(true, functionAsList[1].IsSymbol); 45 | CheckEquals(true, functionAsList[2].IsLanguage); 46 | 47 | dataFrame := FEngine.Evaluate('data.frame(a = rep(LETTERS[1:3], 2), b = rep(1:3, 2))'); 48 | dataFrameAsList := dataFrame.AsList; 49 | CheckEquals(2, dataFrameAsList.VectorLength); 50 | CheckEquals(true, dataFrameAsList[0].IsFactor); 51 | CheckEquals(6, dataFrameAsList[1].AsInteger.VectorLength); 52 | end; 53 | //------------------------------------------------------------------------------ 54 | procedure TListTests.IsList_Test; 55 | var 56 | exprPairList: ISymbolicExpression; 57 | exprList: ISymbolicExpression; 58 | begin 59 | exprPairList := FEngine.Evaluate('pairlist(a=5)'); 60 | exprList := FEngine.Evaluate('list(a=5)'); 61 | CheckEquals(true, exprPairList.IsList); 62 | CheckEquals(true, exprList.IsList); 63 | end; 64 | //------------------------------------------------------------------------------ 65 | procedure TListTests.ListSubsetting_Test; 66 | var 67 | lst: IGenericVector; 68 | vec1: INumericVector; 69 | vec2: INumericVector; 70 | begin 71 | lst := FEngine.Evaluate('c(1.5, 2.5)').AsList; 72 | CheckEquals(2, lst.VectorLength); 73 | 74 | vec1 := lst[0].AsNumeric; 75 | CheckEquals(1, vec1.VectorLength); 76 | Check(SameValue(1.5, vec1[0])); 77 | 78 | vec2 := lst[1].AsNumeric; 79 | CheckEquals(1, vec2.VectorLength); 80 | Check(SameValue(2.5, vec2[0])); 81 | end; 82 | //------------------------------------------------------------------------------ 83 | procedure TListTests.SetUp; 84 | begin 85 | TREngine.SetEnvironmentVariables; 86 | FEngine := TREngine.GetInstance; 87 | end; 88 | //------------------------------------------------------------------------------ 89 | procedure TListTests.TearDown; 90 | begin 91 | inherited; 92 | 93 | end; 94 | 95 | 96 | initialization 97 | TestFramework.RegisterTest(TListTests.Suite); 98 | 99 | end. 100 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | opaR 2 | ===== 3 | 4 | opaR (object pascal for R) is a port of [R.NET 1.6.5](https://github.com/jmp75/rdotnet) to Embarcadero Delphi, allowing you to integrate the popular R statistical language into your Delphi apps. 5 | 6 | Delphi is a natural fit for this - no opaque marshalling and no runtime requirement (as well as being cross-platform). The direct pointer access combined with the .NET-style features available in more recent Delphi versions made the port relatively straightforward. The aim has been to retain the same basic API as in R.NET, allowing simple porting of the numerous R.NET examples found on the web. 7 | 8 | 9 | Requirements 10 | -------------- 11 | 12 | 1. [The Spring4D Collections](https://bitbucket.org/sglienke/spring4d) 13 | 14 | 2. [Generics.Tuples from Malcolm Groves](https://github.com/malcolmgroves/generics.tuples) 15 | 16 | 17 | Notes 18 | ------- 19 | As of Jan 2016: 20 | 21 | 1. This is still beta software - use at your own risk! 22 | 23 | 2. Currently only the non-visual core has been ported. There are no definite plans to port the graphics classes, but it's a possibility. 24 | 25 | 3. Developed in XE7 on Win7 32bit, with x64 testing in Delphi 10 Seattle (on Win8 64bit). Because of it's origins, opaR uses the .NET-style features found in more recent Delphi versions and there are no plans to validate against earlier versions, or against FPC. 26 | 27 | 4. Developed using R 3.2.2 (both 32 and 64 bit on Windows). Not tested with earlier R versions and there are no plans to do so. 28 | 29 | 5. Most of the integration tests provided with R.NET 1.6.5 have been ported, and additional tests from other sources will be added over time. However, there's some way to go before full code coverage is achieved. Testing is based on the DUnit version provided with the IDE. 30 | 31 | 6. Testing on OSX will be started in the near future (and Linux when it becomes available). 32 | 33 | 7. GPL code (and hence R) is not allowed in the Apple AppStore so an iOS port is unlikely, although we'll take a look at Android at some point. 34 | 35 | 8. There are still a few gaps (e.g. handling of complex types, and some Linux-related code) and these will be added in the near future. 36 | 37 | 38 | Licence 39 | -------- 40 | 41 | R itself is released under the GPL and for consistency opaR is similarly licenced (actually Affero GPL). Be aware that if you incorporate opaR into one of your products then you are also, by default, incorporating R and your codebase becomes subject to GPL conditions. Releasing opaR under a licence such as Mozilla (MPL) or Apache won't allow you to avoid the GPL conditions dragged in by R itself, and confuses the situation. opaR is likely to be most useful for software developed for internal corporate use, where there is no requirement to release source code under GPL. 42 | 43 | 44 | Acknowledgements 45 | ------------------- 46 | 47 | This port has been made straightforward by the excellent resources found in the Delphi community, in particular those due to Stefan Glienke, David Heffernan, Rudi Velthuis, Nick Hodges and Remy Lebeau. 48 | 49 | -------------------------------------------------------------------------------- /Tests/CharacterVectorTests.pas: -------------------------------------------------------------------------------- 1 | unit CharacterVectorTests; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | TestFramework, 8 | 9 | opaR.Engine, 10 | opaR.CharacterVector, 11 | opaR.Interfaces; 12 | 13 | type 14 | TCharacterVectorTests = class(TTestCase) 15 | private 16 | FEngine: IREngine; 17 | protected 18 | procedure SetUp; override; 19 | procedure TearDown; override; 20 | published 21 | procedure CharacterVector_ArrayInitialisation_Test; 22 | procedure CharacterVector_Evaluate_Test; 23 | procedure CharacterVector_ToArray_Test; 24 | procedure CharacterVector_SetVectorDirect_Test; 25 | end; 26 | 27 | 28 | implementation 29 | 30 | { TCharacterVectorTests } 31 | 32 | //------------------------------------------------------------------------------ 33 | procedure TCharacterVectorTests.CharacterVector_ArrayInitialisation_Test; 34 | var 35 | arr: TArray; 36 | vec: ICharacterVector; 37 | begin 38 | arr := TArray.Create('aaa', 'bbb', 'ccc', 'ddd', 'eee'); 39 | vec := TCharacterVector.Create(FEngine, arr); 40 | 41 | CheckEquals(5, vec.VectorLength); 42 | CheckEquals('bbb', vec[1]); 43 | CheckEquals('eee', vec[4]); 44 | end; 45 | //------------------------------------------------------------------------------ 46 | procedure TCharacterVectorTests.CharacterVector_Evaluate_Test; 47 | var 48 | s1: string; 49 | s2: string; 50 | vec: ICharacterVector; 51 | begin 52 | s1 := QuotedStr('foo'); 53 | s2 := QuotedStr('bar'); 54 | vec := FEngine.Evaluate('c(' + s1 + ', NA,' + s2 + ')').AsCharacter; 55 | 56 | CheckEquals(3, vec.VectorLength); 57 | CheckEquals('foo', vec[0]); 58 | CheckEquals('', vec[1]); 59 | CheckEquals('bar', vec[2]); 60 | end; 61 | //------------------------------------------------------------------------------ 62 | procedure TCharacterVectorTests.CharacterVector_SetVectorDirect_Test; 63 | var 64 | arr: TArray; 65 | vec: ICharacterVector; 66 | begin 67 | arr := TArray.Create('aaa', 'bbb', 'ccc', 'ddd', 'eee'); 68 | vec := TCharacterVector.Create(FEngine, Length(arr)); 69 | vec.SetVectorDirect(arr); 70 | 71 | CheckEquals(5, vec.VectorLength); 72 | CheckEquals('bbb', vec[1]); 73 | CheckEquals('eee', vec[4]); 74 | end; 75 | //------------------------------------------------------------------------------ 76 | procedure TCharacterVectorTests.CharacterVector_ToArray_Test; 77 | var 78 | arr1: TArray; 79 | arr2: TArray; 80 | vec: ICharacterVector; 81 | begin 82 | arr1 := TArray.Create('aaa', 'bbb', 'ccc', 'ddd', 'eee'); 83 | vec := TCharacterVector.Create(FEngine, arr1); 84 | 85 | arr2 := vec.ToArray; 86 | 87 | CheckEquals('bbb', vec[1]); 88 | CheckEquals('eee', vec[4]); 89 | end; 90 | //------------------------------------------------------------------------------ 91 | procedure TCharacterVectorTests.SetUp; 92 | begin 93 | TREngine.SetEnvironmentVariables; 94 | FEngine := TREngine.GetInstance; 95 | end; 96 | //------------------------------------------------------------------------------ 97 | procedure TCharacterVectorTests.TearDown; 98 | begin 99 | inherited; 100 | 101 | end; 102 | 103 | 104 | initialization 105 | TestFramework.RegisterTest(TCharacterVectorTests.Suite); 106 | 107 | end. 108 | -------------------------------------------------------------------------------- /Src/opaR.Expression.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Expression; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | The constructor requires a pointer (p) to an R expression, which is in turn 25 | stored in the Handle property of the base class. 26 | 27 | -------------------------------------------------------------------------------} 28 | 29 | interface 30 | 31 | uses 32 | opaR.Utils, 33 | opaR.DLLFunctions, 34 | opaR.SEXPREC, 35 | opaR.Environment, 36 | opaR.SymbolicExpression, 37 | opaR.Interfaces; 38 | 39 | 40 | type 41 | TExpression = class(TSymbolicExpression, IExpression) 42 | public 43 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); 44 | function Evaluate(const environment: IREnvironment): ISymbolicExpression; 45 | function TryEvaluate(const environment: IREnvironment; out rtn: ISymbolicExpression): boolean; 46 | end; 47 | 48 | 49 | implementation 50 | 51 | 52 | { TExpression } 53 | 54 | //------------------------------------------------------------------------------ 55 | constructor TExpression.Create(const engine: IREngine; pExpr: PSEXPREC); 56 | begin 57 | inherited Create(engine, pExpr); 58 | end; 59 | //------------------------------------------------------------------------------ 60 | { TODO : check engine match } 61 | function TExpression.Evaluate(const environment: IREnvironment): ISymbolicExpression; 62 | var 63 | PPtr: PSEXPREC; 64 | begin 65 | if environment = nil then 66 | raise EopaRException.Create('Null environment passed to Expression.Evaluate'); 67 | 68 | //if environment.Engine <> Engine then 69 | // raise EopaRException.Create('REngine mismatch in Expression.Evaluate'); 70 | 71 | PPtr := Engine.Rapi.Eval(Handle, environment.Handle); 72 | result := TSymbolicExpression.Create(Engine, PPtr); 73 | end; 74 | //------------------------------------------------------------------------------ 75 | { TODO : check engine match } 76 | function TExpression.TryEvaluate(const environment: IREnvironment; 77 | out rtn: ISymbolicExpression): boolean; 78 | var 79 | errorOccurred: LongBool; 80 | PPtr: PSEXPREC; 81 | begin 82 | if environment = nil then 83 | raise EopaRException.Create('Null environment passed to Expression.TryEvaluate'); 84 | 85 | //if environment.Engine <> Engine then 86 | // raise EopaRException.Create('REngine mismatch in Expression.TryEvaluate'); 87 | 88 | PPtr := Engine.Rapi.TryEval(Handle, environment.Handle, errorOccurred); 89 | 90 | if errorOccurred then 91 | rtn := nil 92 | else 93 | rtn := TSymbolicExpression.Create(Engine, PPtr); 94 | 95 | result := not errorOccurred; 96 | end; 97 | 98 | end. 99 | -------------------------------------------------------------------------------- /Src/opaR.Symbol.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Symbol; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | 23 | interface 24 | 25 | uses 26 | System.SysUtils, 27 | 28 | opaR.SEXPREC, 29 | opaR.InternalString, 30 | opaR.SymbolicExpression, 31 | opaR.Interfaces; 32 | 33 | 34 | type 35 | TSymbol = class(TSymbolicExpression, ISymbol) 36 | private 37 | function GetPrintName: string; 38 | class function GetOffsetOf(fieldName: string): integer; 39 | procedure SetPrintName(const Value: string); 40 | function GetValue: ISymbolicExpression; 41 | function GetInternal: ISymbolicExpression; 42 | public 43 | property PrintName: string read GetPrintName write SetPrintName; 44 | property Internal: ISymbolicExpression read GetInternal; 45 | property Value: ISymbolicExpression read GetValue; 46 | end; 47 | 48 | 49 | implementation 50 | 51 | uses 52 | opaR.EngineExtension; 53 | 54 | { TSymbol } 55 | 56 | //------------------------------------------------------------------------------ 57 | function TSymbol.GetInternal: ISymbolicExpression; 58 | var 59 | sexp: TSEXPREC; 60 | begin 61 | sexp := GetInternalStructure; 62 | if sexp.symsxp.internal = TEngineExtension(Engine).NilValue then { TODO : R.NET checks sexp.symsxp.value??? } 63 | result := nil 64 | else 65 | result := TSymbolicExpression.Create(Engine, sexp.symsxp.internal); 66 | end; 67 | //------------------------------------------------------------------------------ 68 | class function TSymbol.GetOffsetOf(fieldName: string): integer; 69 | begin 70 | { TODO : TSymbol.GetOffsetOf - possibly not needed. } 71 | result := 0; 72 | end; 73 | //------------------------------------------------------------------------------ 74 | function TSymbol.GetPrintName: string; 75 | var 76 | sexp: TSEXPREC; 77 | internalStr: IInternalString; 78 | begin 79 | sexp := GetInternalStructure; 80 | 81 | internalStr := TInternalString.Create(Engine, sexp.symsxp.pname); 82 | result := internalStr.ToString; 83 | end; 84 | //------------------------------------------------------------------------------ 85 | function TSymbol.GetValue: ISymbolicExpression; 86 | var 87 | sexp: TSEXPREC; 88 | begin 89 | sexp := GetInternalStructure; 90 | if sexp.symsxp.value = TEngineExtension(Engine).NilValue then 91 | result := nil 92 | else 93 | result := TSymbolicExpression.Create(Engine, sexp.symsxp.value); 94 | end; 95 | //------------------------------------------------------------------------------ 96 | procedure TSymbol.SetPrintName(const Value: string); 97 | var 98 | Ptr: PSEXPREC; 99 | sexp: TSEXPREC; 100 | internalStr: IInternalString; 101 | begin 102 | if Trim(Value) = '' then 103 | Ptr := TEngineExtension(Engine).NilValue 104 | else 105 | begin 106 | internalStr := TInternalString.Create(Engine, Value); 107 | Ptr := internalStr.Handle; 108 | end; 109 | 110 | sexp := GetInternalStructure; 111 | sexp.symsxp.pname := Ptr; 112 | end; 113 | 114 | end. 115 | -------------------------------------------------------------------------------- /Tests/DataFrameTests.pas: -------------------------------------------------------------------------------- 1 | unit DataFrameTests; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | The "iris" dataset is included in R as a standard dataset and is used as the 6 | basis of the tests in this group. 7 | 8 | -------------------------------------------------------------------------------} 9 | 10 | interface 11 | 12 | uses 13 | System.Math, 14 | TestFramework, 15 | 16 | opaR.Engine, 17 | opaR.SymbolicExpression, 18 | opaR.Interfaces; 19 | 20 | type 21 | TDataFrameTests = class(TTestCase) 22 | private 23 | FEngine: IREngine; 24 | protected 25 | procedure SetUp; override; 26 | procedure TearDown; override; 27 | published 28 | procedure Iris_Test; 29 | procedure IrisSubset_Test; 30 | procedure DataFrameRow_Test; 31 | end; 32 | 33 | implementation 34 | 35 | { TDataFrameTests } 36 | 37 | //------------------------------------------------------------------------------ 38 | procedure TDataFrameTests.DataFrameRow_Test; 39 | var 40 | irisDF: IDataFrame; 41 | row: IDataFrameRow; 42 | begin 43 | irisDF := FEngine.Evaluate('iris').AsDataFrame; 44 | row := irisDF.GetRow(0); 45 | 46 | Check(SameValue(5.1, row[0])); 47 | Check(SameValue(3.5, row['Sepal.Width'])); 48 | Check(SameValue(1.4, row[2])); 49 | Check(SameValue(0.2, row[3])); 50 | CheckEquals('setosa', row[4]); 51 | end; 52 | //------------------------------------------------------------------------------ 53 | procedure TDataFrameTests.IrisSubset_Test; 54 | var 55 | iris50: IDataFrame; 56 | row1: IDataFrameRow; 57 | row50: IDataFrameRow; 58 | begin 59 | iris50 := FEngine.Evaluate('iris[1:50,]').AsDataFrame; 60 | row1 := iris50.GetRow(0); 61 | row50 := iris50.GetRow(49); 62 | 63 | CheckEquals(50, iris50.RowCount); 64 | 65 | // -- Check the first row, getting the columns by name. 66 | Check(SameValue(5.1, row1['Sepal.Length'])); 67 | Check(SameValue(3.5, row1['Sepal.Width'])); 68 | Check(SameValue(1.4, row1['Petal.Length'])); 69 | Check(SameValue(0.2, row1['Petal.Width'])); 70 | CheckEquals('setosa', row1['Species']); 71 | 72 | // -- Check the last row. 73 | Check(SameValue(5.0, row50[0])); 74 | Check(SameValue(3.3, row50['Sepal.Width'])); 75 | Check(SameValue(1.4, row50[2])); 76 | Check(SameValue(0.2, row50[3])); 77 | CheckEquals('setosa', row50[4]); 78 | end; 79 | //------------------------------------------------------------------------------ 80 | procedure TDataFrameTests.Iris_Test; 81 | var 82 | irisDF: IDataFrame; 83 | begin 84 | irisDF := FEngine.Evaluate('iris').AsDataFrame; 85 | 86 | CheckEquals(150, irisDF.RowCount); 87 | Check(SameValue(3.7, irisDF[10, 'Sepal.Width'])); 88 | CheckEquals('setosa', irisDF[10, 4]); 89 | 90 | // -- Note that opaR is using the default row names for "iris", in contrast 91 | // -- to R.NET which enforces the existence of specified row names. 92 | // -- The following line therefore raises an exception in R.NET. 93 | Check(SameValue(3.1, irisDF['10', 'Sepal.Width'])); 94 | 95 | Check(SameValue(5.4, irisDF[10, 0])); 96 | Check(SameValue(4.6, irisDF[47, 0])); 97 | Check(SameValue(3.1, irisDF[52, 1])); 98 | Check(SameValue(3.9, irisDF[59, 2])); 99 | Check(SameValue(2.3, irisDF[141, 3])); 100 | CheckEquals('virginica', irisDF[149, 4]); 101 | end; 102 | //------------------------------------------------------------------------------ 103 | procedure TDataFrameTests.SetUp; 104 | begin 105 | TREngine.SetEnvironmentVariables; 106 | FEngine := TREngine.GetInstance; 107 | end; 108 | //------------------------------------------------------------------------------ 109 | procedure TDataFrameTests.TearDown; 110 | begin 111 | inherited; 112 | 113 | end; 114 | 115 | 116 | initialization 117 | TestFramework.RegisterTest(TDataFrameTests.Suite); 118 | 119 | end. 120 | -------------------------------------------------------------------------------- /Tests/S4Test.pas: -------------------------------------------------------------------------------- 1 | unit S4Test; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | TestFramework, 8 | 9 | Spring.Collections, 10 | 11 | opaR.TestUtils, 12 | opaR.Engine, 13 | opaR.SymbolicExpression, 14 | opaR.Interfaces, 15 | opaR.CharacterVector; 16 | 17 | 18 | type 19 | TS4Tests = class(TTestCase) 20 | private 21 | FEngine: IREngine; 22 | protected 23 | procedure SetUp; override; 24 | procedure TearDown; override; 25 | published 26 | procedure GetSlotTypes_Test; 27 | procedure HasSlot_Test; 28 | procedure GetSlot_Test; 29 | procedure SetSlot_Test; 30 | end; 31 | 32 | implementation 33 | 34 | { TS4Tests } 35 | 36 | //------------------------------------------------------------------------------ 37 | procedure TS4Tests.GetSlotTypes_Test; 38 | var 39 | s4: IS4Object; 40 | test: string; 41 | foo: string; 42 | actual: IDictionary; 43 | begin 44 | test := QuotedStr('testclass'); 45 | foo := QuotedStr('s4'); 46 | s4 := FEngine.Evaluate('new(' + test + ', foo= ' + foo + ', bar=1:4)').AsS4; 47 | actual := s4.GetSlotTypes; 48 | 49 | CheckEquals(2, actual.Count); 50 | CheckEquals(true, actual.ContainsKey('foo')); 51 | CheckEquals('character', actual['foo']); 52 | CheckEquals(true, actual.ContainsKey('bar')); 53 | CheckEquals('integer', actual['bar']); 54 | end; 55 | //------------------------------------------------------------------------------ 56 | procedure TS4Tests.GetSlot_Test; 57 | var 58 | s4: IS4Object; 59 | test: string; 60 | foo: string; 61 | vec: IIntegerVector; 62 | begin 63 | test := QuotedStr('testclass'); 64 | foo := QuotedStr('s4'); 65 | s4 := FEngine.Evaluate('new(' + test + ', foo= ' + foo + ', bar=1:4)').AsS4; 66 | foo := s4['foo'].AsCharacter.First; // -- R.NET test uses a GetSlot method here. 67 | CheckEquals(foo, 's4'); 68 | vec := s4['bar'].AsInteger; 69 | CheckEquals(true, TopaRArrayUtils.IntArraysEqual(TArray.Create(1, 2, 3, 4), vec.ToArray)); 70 | end; 71 | //------------------------------------------------------------------------------ 72 | procedure TS4Tests.HasSlot_Test; 73 | var 74 | s4: IS4Object; 75 | test: string; 76 | foo: string; 77 | begin 78 | test := QuotedStr('testclass'); 79 | foo := QuotedStr('s4'); 80 | s4 := FEngine.Evaluate('new(' + test + ', foo= ' + foo + ', bar=1:4)').AsS4; 81 | CheckEquals(true, s4.HasSlot('foo')); 82 | CheckEquals(true, s4.HasSlot('bar')); 83 | CheckEquals(false, s4.HasSlot('baz')); 84 | end; 85 | //------------------------------------------------------------------------------ 86 | procedure TS4Tests.SetSlot_Test; 87 | var 88 | s4: IS4Object; 89 | test: string; 90 | foo: string; 91 | vec: IIntegerVector; 92 | begin 93 | test := QuotedStr('testclass'); 94 | foo := QuotedStr('s4'); 95 | s4 := FEngine.Evaluate('new(' + test + ', foo= ' + foo + ', bar=1:4)').AsS4; 96 | foo := s4['foo'].AsCharacter.First; // -- R.NET test uses a GetSlot method here. 97 | CheckEquals(foo, 's4'); 98 | s4['foo'] := TCharacterVector.Create(FEngine, TArray.Create('new value')); 99 | foo := s4['foo'].AsCharacter.First; 100 | CheckEquals(foo, 'new value'); 101 | end; 102 | //------------------------------------------------------------------------------ 103 | procedure TS4Tests.SetUp; 104 | var 105 | test: string; 106 | charType: string; 107 | intType: string; 108 | begin 109 | TREngine.SetEnvironmentVariables; 110 | FEngine := TREngine.GetInstance; 111 | 112 | // -- Define the test class at the Setup stage. 113 | test := QuotedStr('testclass'); 114 | charType := QuotedStr('character'); 115 | intType := QuotedStr('integer'); 116 | FEngine.Evaluate('setClass(' + test + ', representation(foo=' + charType + ', bar=' + intType + '))'); 117 | end; 118 | //------------------------------------------------------------------------------ 119 | procedure TS4Tests.TearDown; 120 | begin 121 | inherited; 122 | 123 | end; 124 | 125 | 126 | initialization 127 | TestFramework.RegisterTest(TS4Tests.Suite); 128 | 129 | end. 130 | -------------------------------------------------------------------------------- /Src/opaR.Closure.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Closure; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | Spring.Collections.Dictionaries, 26 | 27 | opaR.Utils, 28 | opaR.SEXPREC, 29 | opaR.RFunction, 30 | opaR.Interfaces, 31 | opaR.PairList, 32 | opaR.Language, 33 | opaR.Environment; 34 | 35 | type 36 | TRClosure = class(TRFunction) 37 | private 38 | function GetArgumentNames: TArray; 39 | function GetArguments: IPairList; 40 | function GetBody: IRLanguage; 41 | function GetEnvironment: IREnvironment; 42 | public 43 | property Arguments: IPairList read GetArguments; 44 | property Body: IRLanguage read GetBody; 45 | property Environment: IREnvironment read GetEnvironment; 46 | function Invoke: ISymbolicExpression; overload; override; 47 | function Invoke(arg: ISymbolicExpression): ISymbolicExpression; overload; override; 48 | function Invoke(args: TArray): ISymbolicExpression; overload; override; 49 | function Invoke(args: TDictionary): ISymbolicExpression; overload; override; 50 | end; 51 | 52 | 53 | 54 | implementation 55 | 56 | uses 57 | opaR.EngineExtension; 58 | 59 | { TRClosure } 60 | 61 | //------------------------------------------------------------------------------ 62 | function TRClosure.GetArgumentNames: TArray; 63 | begin 64 | { TODO : TRClosure.GetArgumentNames } // -- Not used internally by R.NET - implement later. 65 | raise EopaRException.Create('TRClosure.GetArgumentNames not yet implemented'); 66 | result := nil; 67 | end; 68 | //------------------------------------------------------------------------------ 69 | function TRClosure.GetArguments: IPairList; 70 | var 71 | sexp: TSEXPREC; 72 | begin 73 | sexp := GetInternalStructure; 74 | result := TPairList.Create(Engine, sexp.closxp.formals); 75 | end; 76 | //------------------------------------------------------------------------------ 77 | function TRClosure.GetBody: IRLanguage; 78 | var 79 | sexp: TSEXPREC; 80 | begin 81 | sexp := GetInternalStructure; 82 | result := TRLanguage.Create(Engine, sexp.closxp.body); 83 | end; 84 | //------------------------------------------------------------------------------ 85 | function TRClosure.GetEnvironment: IREnvironment; 86 | var 87 | sexp: TSEXPREC; 88 | begin 89 | sexp := GetInternalStructure; 90 | result := TREnvironment.Create(Engine, sexp.closxp.env); 91 | end; 92 | //------------------------------------------------------------------------------ 93 | function TRClosure.Invoke(arg: ISymbolicExpression): ISymbolicExpression; 94 | var 95 | arr: TArray; 96 | begin 97 | arr := TArray.Create(arg); 98 | result := Invoke(arr); 99 | end; 100 | //------------------------------------------------------------------------------ 101 | function TRClosure.Invoke(args: TArray): ISymbolicExpression; 102 | begin 103 | result := InvokeOrderedArguments(args); 104 | end; 105 | //------------------------------------------------------------------------------ 106 | function TRClosure.Invoke(args: TDictionary): ISymbolicExpression; 107 | begin 108 | { TODO : TRClosure.Invoke(args: TDictionary) } 109 | raise EopaRException.Create('TRClosure.Invoke with dictionary not yet implemented'); 110 | result := nil; 111 | end; 112 | //------------------------------------------------------------------------------ 113 | function TRClosure.Invoke: ISymbolicExpression; 114 | begin 115 | result := CreateCallAndEvaluate(TEngineExtension(Engine).NilValue); 116 | end; 117 | 118 | end. 119 | -------------------------------------------------------------------------------- /Tests/ErrorHandlingTests.pas: -------------------------------------------------------------------------------- 1 | unit ErrorHandlingTests; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | In these tests we check that we properly capture errors raised by R, and 6 | reproduce those described in the R.NET tests. 7 | 8 | -------------------------------------------------------------------------------} 9 | 10 | interface 11 | 12 | uses 13 | System.SysUtils, 14 | TestFramework, 15 | 16 | opaR.TestUtils, 17 | 18 | opaR.Engine, 19 | opaR.SymbolicExpression, 20 | opaR.Interfaces, 21 | opaR.Exception; 22 | 23 | 24 | type 25 | TErrorHandlingTests = class(TTestCase) 26 | private 27 | FEngine: IREngine; 28 | protected 29 | procedure SetUp; override; 30 | procedure TearDown; override; 31 | published 32 | procedure FailedExpressionParsing_Test; 33 | procedure FailedExpressionEvaluation_Test; 34 | procedure FailedExpressionParsingMissingParenthesis_Test; 35 | procedure FailedExpressionUnboundSymbol_Test; 36 | procedure FailedExpressionUnboundSymbolEvaluation_Test; 37 | end; 38 | 39 | 40 | implementation 41 | 42 | { TErrorHandlingTests } 43 | 44 | //------------------------------------------------------------------------------ 45 | procedure TErrorHandlingTests.FailedExpressionEvaluation_Test; 46 | var 47 | expectedMsg: string; 48 | begin 49 | expectedMsg := 'Error in fail("bailing out") : the message is bailing out' + #10; 50 | 51 | CheckException(EopaREvaluationException, 52 | procedure 53 | begin 54 | FEngine.Evaluate('fail <- function(msg) {stop(paste( ' + QuotedStr('the message is') + ', msg))}'); 55 | FEngine.Evaluate('fail(' + QuotedStr('bailing out') + ')'); 56 | end, 57 | expectedMsg); 58 | end; 59 | //------------------------------------------------------------------------------ 60 | procedure TErrorHandlingTests.FailedExpressionParsingMissingParenthesis_Test; 61 | var 62 | expectedMsg: string; 63 | begin 64 | expectedMsg := 'Error: object ' + QuotedStr('x1') + ' not found' + #10; 65 | 66 | CheckException(EopaREvaluationException, 67 | procedure 68 | begin 69 | FEngine.Evaluate('x1 <- rep(c(TRUE,FALSE), 55'); 70 | FEngine.Evaluate('x1') 71 | end, 72 | expectedMsg); 73 | end; 74 | //------------------------------------------------------------------------------ 75 | procedure TErrorHandlingTests.FailedExpressionParsing_Test; 76 | var 77 | expectedMsg: string; 78 | begin 79 | expectedMsg := 'Status Error for function(k) substitute(bar(x) = k)' + #10 + ' : unexpected ' + QuotedStr('='); 80 | 81 | CheckException(EopaRParseException, 82 | procedure 83 | begin 84 | FEngine.Evaluate('function(k) substitute(bar(x) = k)') 85 | end, 86 | expectedMsg); 87 | end; 88 | //------------------------------------------------------------------------------ 89 | procedure TErrorHandlingTests.FailedExpressionUnboundSymbolEvaluation_Test; 90 | var 91 | expectedMsg: string; 92 | begin 93 | expectedMsg := 'Error: object ' + QuotedStr('x2') + ' not found' + #10; 94 | 95 | CheckException(EopaREvaluationException, 96 | procedure 97 | begin 98 | FEngine.Evaluate('x2') 99 | end, 100 | expectedMsg); 101 | end; 102 | //------------------------------------------------------------------------------ 103 | procedure TErrorHandlingTests.FailedExpressionUnboundSymbol_Test; 104 | var 105 | expectedMsg: string; 106 | begin 107 | expectedMsg := 'Error: Object ' + QuotedStr('x3') + ' not found'; 108 | 109 | CheckException(EopaREvaluationException, 110 | procedure 111 | begin 112 | FEngine.GetSymbol('x3') 113 | end, 114 | expectedMsg); 115 | end; 116 | //------------------------------------------------------------------------------ 117 | procedure TErrorHandlingTests.SetUp; 118 | begin 119 | TREngine.SetEnvironmentVariables; 120 | FEngine := TREngine.GetInstance; 121 | end; 122 | //------------------------------------------------------------------------------ 123 | procedure TErrorHandlingTests.TearDown; 124 | begin 125 | inherited; 126 | 127 | end; 128 | 129 | 130 | initialization 131 | TestFramework.RegisterTest(TErrorHandlingTests.Suite); 132 | 133 | end. 134 | -------------------------------------------------------------------------------- /Src/opaR.DataFrameRow.pas: -------------------------------------------------------------------------------- 1 | unit opaR.DataFrameRow; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | In R.NET, DataFrameRow inherits from DynamicObject allowing us to access the 25 | column names using dynamic properties. 26 | 27 | -------------------------------------------------------------------------------} 28 | 29 | interface 30 | 31 | uses 32 | System.Variants, 33 | 34 | opaR.Interfaces, 35 | opaR.DataFrame; 36 | 37 | 38 | type 39 | TDataFrameRow = class(TInterfacedObject, IDataFrameRow) 40 | private 41 | FDataFrame: TDataFrame; 42 | FRowIndex: integer; 43 | function GetRowIndex: integer; 44 | protected 45 | function GetValue(ix: integer): Variant; 46 | procedure SetValue(ix: integer; const Value: Variant); 47 | function GetValueByName(name: string): Variant; 48 | procedure SetValueByName(name: string; const Value: Variant); 49 | function GetInnerValue(ix: integer): Variant; 50 | procedure SetInnerValue(ix: integer; const Value: Variant); 51 | public 52 | constructor Create(df: TDataFrame; rowIndex: integer); 53 | property DataFrame: TDataFrame read FDataFrame; 54 | property RowIndex: integer read GetRowIndex; 55 | property Values[ix: integer]: Variant read GetValue write SetValue; default; 56 | property Values[name: string]: Variant read GetValueByName write SetValueByName; default; 57 | end; 58 | 59 | implementation 60 | 61 | uses 62 | opaR.DynamicVector, 63 | opaR.SymbolicExpression; 64 | 65 | { TDataFrameRow } 66 | 67 | //------------------------------------------------------------------------------ 68 | constructor TDataFrameRow.Create(df: TDataFrame; rowIndex: integer); 69 | begin 70 | FDataFrame := df; 71 | FRowIndex := rowIndex; 72 | end; 73 | //------------------------------------------------------------------------------ 74 | function TDataFrameRow.GetInnerValue(ix: integer): Variant; 75 | var 76 | vec: IDynamicVector; 77 | begin 78 | vec := DataFrame[ix]; 79 | 80 | if (vec as TSymbolicExpression).IsFactor then 81 | result := (vec as TSymbolicExpression).AsInteger[RowIndex] 82 | else 83 | result := vec[RowIndex]; 84 | end; 85 | //------------------------------------------------------------------------------ 86 | function TDataFrameRow.GetRowIndex: integer; 87 | begin 88 | result := FRowIndex; 89 | end; 90 | //------------------------------------------------------------------------------ 91 | function TDataFrameRow.GetValue(ix: integer): Variant; 92 | var 93 | vec: IDynamicVector; 94 | begin 95 | vec := DataFrame[ix]; 96 | result := vec[RowIndex]; 97 | end; 98 | //------------------------------------------------------------------------------ 99 | function TDataFrameRow.GetValueByName(name: string): Variant; 100 | var 101 | vec: IDynamicVector; 102 | begin 103 | vec := DataFrame[name]; 104 | result := vec[RowIndex]; 105 | end; 106 | //------------------------------------------------------------------------------ 107 | procedure TDataFrameRow.SetInnerValue(ix: integer; const Value: Variant); 108 | var 109 | vec: IDynamicVector; 110 | begin 111 | vec := DataFrame[ix]; 112 | 113 | if (vec as TSymbolicExpression).IsFactor then 114 | (vec as TSymbolicExpression).AsInteger[RowIndex] := Value.AsInteger 115 | else 116 | vec[RowIndex] := Value; 117 | end; 118 | //------------------------------------------------------------------------------ 119 | procedure TDataFrameRow.SetValue(ix: integer; const Value: Variant); 120 | var 121 | vec: IDynamicVector; 122 | begin 123 | vec := DataFrame[ix]; 124 | vec[RowIndex] := Value; 125 | end; 126 | //------------------------------------------------------------------------------ 127 | procedure TDataFrameRow.SetValueByName(name: string; const Value: Variant); 128 | var 129 | vec: IDynamicVector; 130 | begin 131 | vec := DataFrame[name]; 132 | vec[RowIndex] := Value; 133 | end; 134 | 135 | end. 136 | -------------------------------------------------------------------------------- /Src/opaR.ExpressionVector.pas: -------------------------------------------------------------------------------- 1 | unit opaR.ExpressionVector; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | TExpressionVector is a wrapper around the SEXPREC generated by the R_ParseVector 25 | function. This contrasts with other vector types which are wrappers for R 26 | vectors generated by Rf_allocVector. 27 | 28 | -------------------------------------------------------------------------------} 29 | 30 | interface 31 | 32 | uses 33 | opaR.Utils, 34 | opaR.ProtectedPointer, 35 | opaR.SEXPREC, 36 | opaR.Vector, 37 | opaR.Interfaces, 38 | opaR.Expression; 39 | 40 | type 41 | TExpressionVector = class(TRVector, IExpressionVector) 42 | protected 43 | function GetDataSize: integer; override; 44 | function GetValue(ix: integer): IExpression; override; 45 | procedure SetValue(ix: integer; value: IExpression); override; 46 | public 47 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); 48 | function GetArrayFast: TArray; override; 49 | procedure SetVectorDirect(const values: TArray); override; 50 | end; 51 | 52 | implementation 53 | 54 | uses 55 | opaR.EngineExtension; 56 | 57 | { TExpressionVector } 58 | 59 | //------------------------------------------------------------------------------ 60 | constructor TExpressionVector.Create(const engine: IREngine; pExpr: PSEXPREC); 61 | begin 62 | inherited Create(engine, pExpr); 63 | end; 64 | //------------------------------------------------------------------------------ 65 | function TExpressionVector.GetArrayFast: TArray; 66 | var 67 | i: integer; 68 | begin 69 | SetLength(result, VectorLength); 70 | for i := 0 to VectorLength - 1 do 71 | result[i] := GetValue(i); 72 | end; 73 | //------------------------------------------------------------------------------ 74 | function TExpressionVector.GetDataSize: integer; 75 | begin 76 | result := SizeOf(PSEXPREC); 77 | end; 78 | //------------------------------------------------------------------------------ 79 | function TExpressionVector.GetValue(ix: integer): IExpression; 80 | var 81 | PPtr: PSEXPREC; 82 | pp: TProtectedPointer; 83 | begin 84 | if (ix < 0) or (ix >= VectorLength) then 85 | raise EopaRException.Create('Error: Vector index out of bounds'); 86 | 87 | pp := TProtectedPointer.Create(self); 88 | try 89 | PPtr := PSEXPREC(PPointerArray(DataPointer)^[ix]); 90 | 91 | if (PPtr = nil) or (PPtr = TEngineExtension(Engine).NilValue) then 92 | result := nil 93 | else 94 | // -- Lifetime management of the returned TExpression is the 95 | // -- responsibility of the calling code. 96 | result := TExpression.Create(Engine, PPtr); 97 | finally 98 | pp.Free; 99 | end; 100 | end; 101 | //------------------------------------------------------------------------------ 102 | //-- Note that TExpressionVector does not get involved in any lifetime management 103 | //-- of TExpression objects - in SetValue we just copy the pointer value to the 104 | //-- internal R vector. 105 | procedure TExpressionVector.SetValue(ix: integer; value: IExpression); 106 | var 107 | PData: PSEXPREC; 108 | pp: TProtectedPointer; 109 | begin 110 | if (ix < 0) or (ix >= VectorLength) then 111 | raise EopaRException.Create('Error: Vector index out of bounds'); 112 | 113 | pp := TProtectedPointer.Create(self); 114 | try 115 | if value = nil then 116 | PData := TEngineExtension(Engine).NilValue 117 | else 118 | PData := value.Handle; 119 | 120 | PPointerArray(DataPointer)^[ix] := PData; 121 | finally 122 | pp.Free; 123 | end; 124 | end; 125 | //------------------------------------------------------------------------------ 126 | procedure TExpressionVector.SetVectorDirect(const values: TArray); 127 | var 128 | i: integer; 129 | begin 130 | for i := 0 to Length(values) - 1 do 131 | SetValue(i, values[i]); 132 | end; 133 | 134 | end. 135 | -------------------------------------------------------------------------------- /Tests/UnivariateStatsTests.pas: -------------------------------------------------------------------------------- 1 | unit UnivariateStatsTests; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | 1. The t-Test tests are based on the one described in the R.NET documentation. 6 | 7 | -------------------------------------------------------------------------------} 8 | 9 | interface 10 | 11 | uses 12 | System.Math, 13 | TestFramework, 14 | Generics.Tuples, // From https://github.com/malcolmgroves/generics.tuples 15 | 16 | opaR.Engine, 17 | opaR.NumericVector, 18 | opaR.GenericVector, 19 | opaR.SymbolicExpression, 20 | opaR.Interfaces, 21 | opaR.Pairlist, 22 | opaR.Symbol; 23 | 24 | 25 | type 26 | TUnivariateStatsTests = class(TTestCase) 27 | private 28 | FEngine: IREngine; 29 | protected 30 | procedure SetUp; override; 31 | procedure TearDown; override; 32 | published 33 | procedure FTest_Test; 34 | procedure tTest_Test; 35 | end; 36 | 37 | implementation 38 | 39 | { TUnivariateStatsTests } 40 | 41 | //------------------------------------------------------------------------------ 42 | //-- In this test use the Engine.Evaluate method to add the data. 43 | procedure TUnivariateStatsTests.FTest_Test; 44 | var 45 | group1: INumericVector; 46 | group2: INumericVector; 47 | testResult: IGenericVector; 48 | lst: IPairList; 49 | arrTuple: TArray>; 50 | p: double; 51 | i: integer; 52 | numVec: INumericVector; 53 | begin 54 | group1 := FEngine.Evaluate('group1 <- c(175.0, 168.0, 168.0, 190.0, 156.0, 181.0, 182.0, 175.0, 174.0, 179.0)').AsNumeric; 55 | group2 := FEngine.Evaluate('group2 <- c(185.0, 169.0, 173.0, 173.0, 188.0, 186.0, 175.0, 174.0, 179.0, 180.0)').AsNumeric; 56 | 57 | testResult := FEngine.Evaluate('var.test(group1, group2)').AsList; 58 | 59 | // -- Convert the generic vector to an R PairList. 60 | lst := testResult.ToPairlist; 61 | // -- Convert the R PairList to an array of tuples. 62 | arrTuple := lst.ToTupleArray; 63 | 64 | // -- Check that the PairList and Tuple conversions are working by 65 | // -- searching for the "statistic" symbol. 66 | for i := 0 to Length(arrTuple) - 1 do 67 | begin 68 | if arrTuple[i].Value1.PrintName = 'statistic' then 69 | begin 70 | numVec := arrTuple[i].Value2.AsNumeric; 71 | p := numVec[0]; 72 | break; 73 | end; 74 | end; 75 | 76 | Check(SameValue(0.283425541040142, testResult['p.value'].AsNumeric.First, 0.000000000000001)); 77 | Check(SameValue(2.10278372591006, p, 0.000000000000005)); 78 | end; 79 | //------------------------------------------------------------------------------ 80 | procedure TUnivariateStatsTests.SetUp; 81 | begin 82 | TREngine.SetEnvironmentVariables; 83 | FEngine := TREngine.GetInstance; 84 | end; 85 | //------------------------------------------------------------------------------ 86 | procedure TUnivariateStatsTests.TearDown; 87 | begin 88 | inherited; 89 | 90 | end; 91 | //------------------------------------------------------------------------------ 92 | procedure TUnivariateStatsTests.tTest_Test; 93 | var 94 | group1: INumericVector; 95 | group2: INumericVector; 96 | arr1: TArray; 97 | arr2: TArray; 98 | testResult: IGenericVector; 99 | pairList: IPairlist; 100 | arr: TArray; 101 | begin 102 | arr1 := TArray.Create(30.02, 29.99, 30.11, 29.97, 30.01, 29.99); 103 | group1 := TNumericVector.Create(FEngine, arr1); 104 | FEngine.SetSymbol('group1', group1 as ISymbolicExpression); 105 | 106 | arr2 := TArray.Create(29.89, 29.93, 29.72, 29.98, 30.02, 29.98); 107 | group2 := TNumericVector.Create(FEngine, arr2); 108 | FEngine.SetSymbol('group2', group2 as ISymbolicExpression); 109 | 110 | testResult := FEngine.Evaluate('t.test(group1, group2)').AsList; 111 | pairList := testResult.ToPairlist; 112 | arr := pairList.ToArray; 113 | 114 | CheckEquals(9, testResult.VectorLength); 115 | CheckEquals(9, pairList.Count); 116 | CheckEquals(9, Length(arr)); 117 | Check(SameValue(0.090773324285671, testResult['p.value'].AsNumeric.First)); 118 | Check(SameValue(1.95900580810807, testResult['statistic'].AsNumeric.First)); 119 | // -- The following is the lower bound of the confidence interval. 120 | Check(SameValue(-0.0195690896460436, testResult['conf.int'].AsNumeric.First)); 121 | // -- The following is the upper bound of the confidence interval. 122 | // -- Note that the following fails with the default epsilon in SameValue. 123 | // -- Float literals in Delphi Win32 are of extended type, so we can use 124 | // -- 16 digits after the decimal point in the epsilon below. 125 | // -- One option would be to use the extended type throughout opaR, 126 | // -- but extended is not supported in Delphi 64-bit. 127 | Check(SameValue(0.209569089646041, testResult['conf.int'].AsNumeric[1], 0.000000000000001)); 128 | end; 129 | 130 | 131 | initialization 132 | TestFramework.RegisterTest(TUnivariateStatsTests.Suite); 133 | 134 | end. 135 | -------------------------------------------------------------------------------- /Tests/MatrixTests.pas: -------------------------------------------------------------------------------- 1 | unit MatrixTests; 2 | 3 | interface 4 | 5 | uses 6 | System.Math, 7 | TestFramework, 8 | 9 | opaR.Engine, 10 | opaR.SymbolicExpression, 11 | opaR.Interfaces; 12 | 13 | type 14 | TMatrixTests = class(TTestCase) 15 | private 16 | FEngine: IREngine; 17 | protected 18 | procedure SetUp; override; 19 | procedure TearDown; override; 20 | published 21 | procedure CharacterMatrix_Test; 22 | procedure Dim_Test; 23 | procedure IntegerMatrix_Test; 24 | procedure NumericMatrix_Test; 25 | end; 26 | 27 | 28 | implementation 29 | 30 | { TMatrixTests } 31 | 32 | //------------------------------------------------------------------------------ 33 | //-- This test starts with the standard iris dataset and coerces it to a 34 | //-- character matrix. 35 | procedure TMatrixTests.CharacterMatrix_Test; 36 | var 37 | iris: IDataFrame; 38 | matrix: ICharacterMatrix; 39 | begin 40 | iris := FEngine.Evaluate('iris').AsDataFrame; 41 | // -- Because there is a non-numeric column in iris, R coerces all columns 42 | // -- to character type. 43 | matrix := FEngine.Evaluate('iris.mat <- as.matrix(iris)').AsCharacterMatrix; 44 | 45 | CheckEquals(150, matrix.RowCount); 46 | CheckEquals(5, matrix.ColumnCount); 47 | CheckEquals(true, (matrix as TSymbolicExpression).IsMatrix); 48 | 49 | CheckEquals('5.4', matrix[10, 0]); 50 | CheckEquals('4.6', matrix[47, 0]); 51 | CheckEquals('3.1', matrix[52, 1]); 52 | CheckEquals('3.9', matrix[59, 2]); 53 | CheckEquals('2.3', matrix[141, 3]); 54 | CheckEquals('virginica', matrix[149, 4]); 55 | end; 56 | //------------------------------------------------------------------------------ 57 | //-- Note that Dim_Test also tests the ILogicalVector type. 58 | procedure TMatrixTests.Dim_Test; 59 | var 60 | dimVec: IIntegerVector; 61 | boolVec: ILogicalVector; 62 | begin 63 | FEngine.Evaluate('vec <- 1:24'); 64 | dimVec := FEngine.Evaluate('dim(vec) <- c(6, 4)').AsInteger; 65 | 66 | // -- dimVec holds the matrix dimensions in a 2-element vector. 67 | CheckEquals(true, (dimVec as TSymbolicExpression).IsVector); 68 | CheckEquals(2, dimVec.VectorLength); 69 | CheckEquals(6, dimVec[0]); 70 | CheckEquals(4, dimVec[1]); 71 | 72 | boolVec := FEngine.Evaluate('is.matrix(vec)').AsLogical; 73 | CheckEquals(1, boolVec.VectorLength); 74 | CheckEquals(true, boolVec[0]); 75 | end; 76 | //------------------------------------------------------------------------------ 77 | //-- This test constructs an integer matrix from an integer vector using the 78 | //-- dim() function. 79 | procedure TMatrixTests.IntegerMatrix_Test; 80 | var 81 | vec: IIntegerVector; 82 | vec2: IIntegerVector; 83 | matrix1: IIntegerMatrix; 84 | matrix2: IIntegerMatrix; 85 | begin 86 | vec := FEngine.Evaluate('vec <- 1:25').AsInteger; 87 | FEngine.Evaluate('dim(vec) <- c(5, 5)'); 88 | matrix1 := FEngine.Evaluate('vec').AsIntegerMatrix; 89 | 90 | CheckEquals(5, matrix1.RowCount); 91 | CheckEquals(5, matrix1.ColumnCount); 92 | CheckEquals(6, matrix1[0, 1]); 93 | CheckEquals(21, matrix1[0, 4]); 94 | CheckEquals(5, matrix1[4, 0]); 95 | CheckEquals(25, matrix1[4, 4]); 96 | 97 | // -- The default in R is to fill columns first. 98 | // -- Use byrow=TRUE to fill rows first. 99 | vec2 := FEngine.Evaluate('vec2 <- 1:25').AsInteger; 100 | FEngine.Evaluate('mtx <- matrix(vec2, 5, byrow=TRUE)'); 101 | matrix2 := FEngine.Evaluate('mtx').AsIntegerMatrix; 102 | 103 | CheckEquals(5, matrix2.RowCount); 104 | CheckEquals(5, matrix2.ColumnCount); 105 | CheckEquals(2, matrix2[0, 1]); 106 | CheckEquals(5, matrix2[0, 4]); 107 | CheckEquals(21, matrix2[4, 0]); 108 | CheckEquals(25, matrix2[4, 4]); 109 | end; 110 | //------------------------------------------------------------------------------ 111 | //-- This test starts with the standard iris dataset and extracts the first 112 | //-- four columns (which are numeric) to create a numeric matrix. 113 | procedure TMatrixTests.NumericMatrix_Test; 114 | var 115 | iris: IDataFrame; 116 | matrix: INumericMatrix; 117 | begin 118 | iris := FEngine.Evaluate('iris').AsDataFrame; 119 | matrix := FEngine.Evaluate('iris.mat <- as.matrix(iris[,1:4])').AsNumericMatrix; 120 | 121 | CheckEquals(150, matrix.RowCount); 122 | CheckEquals(4, matrix.ColumnCount); 123 | Check(SameValue(5.4, matrix[10, 0])); 124 | Check(SameValue(4.6, matrix[47, 0])); 125 | Check(SameValue(3.1, matrix[52, 1])); 126 | Check(SameValue(3.9, matrix[59, 2])); 127 | Check(SameValue(2.3, matrix[141, 3])); 128 | end; 129 | //------------------------------------------------------------------------------ 130 | procedure TMatrixTests.SetUp; 131 | begin 132 | TREngine.SetEnvironmentVariables; 133 | FEngine := TREngine.GetInstance; 134 | end; 135 | //------------------------------------------------------------------------------ 136 | procedure TMatrixTests.TearDown; 137 | begin 138 | inherited; 139 | 140 | end; 141 | 142 | 143 | initialization 144 | TestFramework.RegisterTest(TMatrixTests.Suite); 145 | 146 | end. 147 | -------------------------------------------------------------------------------- /Src/opaR.LogicalMatrix.pas: -------------------------------------------------------------------------------- 1 | unit opaR.LogicalMatrix; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | opaR.Utils, 26 | opaR.Matrix, 27 | opaR.ProtectedPointer, 28 | opaR.Interfaces; 29 | 30 | type 31 | TLogicalMatrix = class(TRMatrix, ILogicalMatrix) 32 | protected 33 | function GetDataSize: integer; override; 34 | function GetValue(rowIndex, columnIndex: integer): LongBool; override; 35 | procedure InitMatrixFastDirect(matrix: TDynMatrix); override; 36 | procedure SetValue(rowIndex, columnIndex: integer; value: LongBool); override; 37 | public 38 | constructor Create(const engine: IREngine; numRows, numCols: integer); overload; 39 | constructor Create(const engine: IREngine; matrix: TDynMatrix); overload; 40 | function GetArrayFast: TDynMatrix; override; 41 | end; 42 | 43 | implementation 44 | 45 | { TLogicalMatrix } 46 | 47 | //------------------------------------------------------------------------------ 48 | constructor TLogicalMatrix.Create(const engine: IREngine; numRows, 49 | numCols: integer); 50 | begin 51 | inherited Create(engine, TSymbolicExpressionType.LogicalVector, numRows, numCols); 52 | end; 53 | //------------------------------------------------------------------------------ 54 | constructor TLogicalMatrix.Create(const engine: IREngine; 55 | matrix: TDynMatrix); 56 | begin 57 | inherited Create(engine, TSymbolicExpressionType.LogicalVector, matrix); 58 | end; 59 | //------------------------------------------------------------------------------ 60 | function TLogicalMatrix.GetArrayFast: TDynMatrix; 61 | var 62 | i: integer; 63 | j: integer; 64 | begin 65 | SetLength(result, RowCount, ColumnCount); 66 | 67 | for i := 0 to RowCount - 1 do 68 | for j := 0 to ColumnCount - 1 do 69 | result[i, j] := GetValue(i, j); 70 | end; 71 | //------------------------------------------------------------------------------ 72 | function TLogicalMatrix.GetDataSize: integer; 73 | begin 74 | result := SizeOf(LongBool); 75 | end; 76 | //------------------------------------------------------------------------------ 77 | function TLogicalMatrix.GetValue(rowIndex, columnIndex: integer): LongBool; 78 | var 79 | pp: TProtectedPointer; 80 | PData: PLongBool; 81 | offset: integer; 82 | begin 83 | if (rowIndex < 0) or (rowIndex >= RowCount) then 84 | raise EopaRException.Create('Error: row index out of bounds'); 85 | 86 | if (columnIndex < 0) or (columnIndex >= ColumnCount) then 87 | raise EopaRException.Create('Error: column index out of bounds'); 88 | 89 | pp := TProtectedPointer.Create(self); 90 | try 91 | offset := GetOffset(rowIndex, columnIndex); 92 | PData := PLongBool(NativeInt(DataPointer) + offset); 93 | result := PData^; 94 | finally 95 | pp.Free; 96 | end; 97 | end; 98 | //------------------------------------------------------------------------------ 99 | procedure TLogicalMatrix.InitMatrixFastDirect(matrix: TDynMatrix); 100 | var 101 | numRows: integer; 102 | numCols: integer; 103 | i: integer; 104 | j: integer; 105 | begin 106 | numRows := Length(matrix); 107 | if numRows <= 0 then 108 | raise EopaRException.Create('Error: Matrix rowCount must be greater than zero'); 109 | 110 | // -- Default memory layout for R is column-major, while Delphi is row-major, 111 | // -- so can't copy blocks. 112 | numCols := Length(matrix[0]); 113 | for i := 0 to numRows - 1 do 114 | for j := 0 to numCols - 1 do 115 | SetValue(i, j, matrix[i, j]); 116 | end; 117 | //------------------------------------------------------------------------------ 118 | procedure TLogicalMatrix.SetValue(rowIndex, columnIndex: integer; 119 | value: LongBool); 120 | var 121 | pp: TProtectedPointer; 122 | PData: PLongBool; 123 | offset: integer; 124 | begin 125 | if (rowIndex < 0) or (rowIndex >= RowCount) then 126 | raise EopaRException.Create('Error: row index out of bounds'); 127 | 128 | if (columnIndex < 0) or (columnIndex >= ColumnCount) then 129 | raise EopaRException.Create('Error: column index out of bounds'); 130 | 131 | pp := TProtectedPointer.Create(self); 132 | try 133 | offset := GetOffset(rowIndex, columnIndex); 134 | PData := PLongBool(NativeInt(DataPointer) + offset); 135 | PData^ := value; 136 | finally 137 | pp.Free; 138 | end; 139 | end; 140 | 141 | end. 142 | -------------------------------------------------------------------------------- /Src/opaR.IntegerMatrix.pas: -------------------------------------------------------------------------------- 1 | unit opaR.IntegerMatrix; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | opaR.Utils, 26 | opaR.Matrix, 27 | opaR.ProtectedPointer, 28 | opaR.Interfaces; 29 | 30 | type 31 | TIntegerMatrix = class(TRMatrix, IIntegerMatrix) 32 | protected 33 | function GetDataSize: integer; override; 34 | function GetValue(rowIndex, columnIndex: integer): integer; override; 35 | procedure InitMatrixFastDirect(matrix: TDynMatrix); override; 36 | procedure SetValue(rowIndex, columnIndex: integer; value: integer); override; 37 | public 38 | constructor Create(const engine: IREngine; numRows, numCols: integer); overload; 39 | constructor Create(const engine: IREngine; matrix: TDynMatrix); overload; 40 | function GetArrayFast: TDynMatrix; override; 41 | end; 42 | 43 | 44 | implementation 45 | 46 | { TIntegerMatrix } 47 | 48 | //------------------------------------------------------------------------------ 49 | constructor TIntegerMatrix.Create(const engine: IREngine; numRows, 50 | numCols: integer); 51 | begin 52 | inherited Create(engine, TSymbolicExpressionType.IntegerVector, numRows, numCols); 53 | end; 54 | //------------------------------------------------------------------------------ 55 | constructor TIntegerMatrix.Create(const engine: IREngine; 56 | matrix: TDynMatrix); 57 | begin 58 | inherited Create(engine, TSymbolicExpressionType.IntegerVector, matrix); 59 | end; 60 | //------------------------------------------------------------------------------ 61 | function TIntegerMatrix.GetArrayFast: TDynMatrix; 62 | var 63 | i: integer; 64 | j: integer; 65 | begin 66 | SetLength(result, RowCount, ColumnCount); 67 | 68 | for i := 0 to RowCount - 1 do 69 | for j := 0 to ColumnCount - 1 do 70 | result[i, j] := GetValue(i, j); 71 | end; 72 | //------------------------------------------------------------------------------ 73 | function TIntegerMatrix.GetDataSize: integer; 74 | begin 75 | result := SizeOf(integer); 76 | end; 77 | //------------------------------------------------------------------------------ 78 | function TIntegerMatrix.GetValue(rowIndex, columnIndex: integer): integer; 79 | var 80 | pp: TProtectedPointer; 81 | PData: PInteger; 82 | offset: integer; 83 | begin 84 | if (rowIndex < 0) or (rowIndex >= RowCount) then 85 | raise EopaRException.Create('Error: row index out of bounds'); 86 | 87 | if (columnIndex < 0) or (columnIndex >= ColumnCount) then 88 | raise EopaRException.Create('Error: column index out of bounds'); 89 | 90 | pp := TProtectedPointer.Create(self); 91 | try 92 | offset := GetOffset(rowIndex, columnIndex); 93 | PData := PInteger(NativeInt(DataPointer) + offset); 94 | result := PData^; 95 | finally 96 | pp.Free; 97 | end; 98 | end; 99 | //------------------------------------------------------------------------------ 100 | procedure TIntegerMatrix.InitMatrixFastDirect(matrix: TDynMatrix); 101 | var 102 | numRows: integer; 103 | numCols: integer; 104 | i: integer; 105 | j: integer; 106 | begin 107 | numRows := Length(matrix); 108 | if numRows <= 0 then 109 | raise EopaRException.Create('Error: Matrix rowCount must be greater than zero'); 110 | 111 | // -- Default memory layout for R is column-major, while Delphi is row-major, 112 | // -- so can't copy blocks. 113 | { TODO : An R matrix can be created as row-major, but need to test for this before copying blocks. } 114 | numCols := Length(matrix[0]); 115 | for i := 0 to numRows - 1 do 116 | for j := 0 to numCols - 1 do 117 | SetValue(i, j, matrix[i, j]); 118 | end; 119 | //------------------------------------------------------------------------------ 120 | procedure TIntegerMatrix.SetValue(rowIndex, columnIndex, value: integer); 121 | var 122 | pp: TProtectedPointer; 123 | PData: PInteger; 124 | offset: integer; 125 | begin 126 | if (rowIndex < 0) or (rowIndex >= RowCount) then 127 | raise EopaRException.Create('Error: row index out of bounds'); 128 | 129 | if (columnIndex < 0) or (columnIndex >= ColumnCount) then 130 | raise EopaRException.Create('Error: column index out of bounds'); 131 | 132 | pp := TProtectedPointer.Create(self); 133 | try 134 | offset := GetOffset(rowIndex, columnIndex); 135 | PData := PInteger(NativeInt(DataPointer) + offset); 136 | PData^ := value; 137 | finally 138 | pp.Free; 139 | end; 140 | end; 141 | 142 | end. 143 | 144 | 145 | 146 | 147 | -------------------------------------------------------------------------------- /Src/opaR.Environment.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Environment; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | System.SysUtils, 26 | System.Types, 27 | 28 | opaR.Utils, 29 | opaR.SEXPREC, 30 | opaR.DLLFunctions, 31 | opaR.SymbolicExpression, 32 | opaR.Interfaces, 33 | opaR.Exception; 34 | 35 | 36 | type 37 | TREnvironment = class(TSymbolicExpression, IREnvironment) 38 | private 39 | function GetParent: IREnvironment; 40 | //function GetEngineHandle: HMODULE; 41 | //function GetHandle: PSEXPREC; 42 | public 43 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); overload; 44 | constructor Create(const engine: IREngine; parent: IREnvironment); overload; 45 | //function GetInternalStructure: TSEXPREC; 46 | function GetSymbol(symbolName: string): ISymbolicExpression; 47 | function GetSymbolNames(includeSpecialFunctions: LongBool): TArray; 48 | procedure SetSymbol(symbolName: string; expression: ISymbolicExpression); 49 | //property EngineHandle: HMODULE read GetEngineHandle; 50 | //property Handle: PSEXPREC read GetHandle; 51 | property Parent: IREnvironment read GetParent; 52 | end; 53 | 54 | 55 | implementation 56 | 57 | uses 58 | opaR.EngineExtension, 59 | opaR.CharacterVector; 60 | 61 | { TREnvironment } 62 | 63 | //------------------------------------------------------------------------------ 64 | constructor TREnvironment.Create(const engine: IREngine; pExpr: PSEXPREC); 65 | begin 66 | inherited Create(engine, pExpr); 67 | end; 68 | //------------------------------------------------------------------------------ 69 | constructor TREnvironment.Create(const engine: IREngine; parent: IREnvironment); 70 | var 71 | pExpr: PSEXPREC; 72 | nilPtr: PSEXPREC; 73 | begin 74 | nilPtr := TEngineExtension(engine).NilValue; 75 | pExpr := engine.Rapi.NewEnvironment(nilPtr, nilPtr, parent.Handle); 76 | 77 | inherited Create(engine, pExpr); 78 | end; 79 | //------------------------------------------------------------------------------ 80 | function TREnvironment.GetParent: IREnvironment; 81 | var 82 | sexp: TSEXPREC; 83 | p: PSEXPREC; 84 | begin 85 | sexp := GetInternalStructure; 86 | p := sexp.envsxp.enclos; 87 | if p = nil then 88 | result := nil 89 | else 90 | result := TREnvironment.Create(Engine, p); 91 | end; 92 | //------------------------------------------------------------------------------ 93 | function TREnvironment.GetSymbol(symbolName: string): ISymbolicExpression; 94 | var 95 | installedName: PSEXPREC; 96 | pVar: PSEXPREC; 97 | sexp: TSEXPREC; 98 | begin 99 | result := nil; 100 | 101 | if symbolName = '' then 102 | raise EopaRException.Create('Symbol name cannot be null'); 103 | 104 | installedName := Engine.Rapi.Install(PAnsiChar(AnsiString(symbolName))); 105 | pVar := Engine.Rapi.FindVar(installedName, Handle); 106 | 107 | if TEngineExtension(Engine).CheckUnbound(pVar) then 108 | raise EopaREvaluationException.CreateFmt('Error: Object %s not found', [QuotedStr(symbolName)]); 109 | 110 | sexp := pVar^; 111 | if TSymbolicExpressionType(sexp.sxpinfo.type_) = TSymbolicExpressionType.Promise then 112 | pVar := Engine.Rapi.Eval(pVar, Handle); 113 | 114 | result := TSymbolicExpression.Create(Engine, pVar); 115 | end; 116 | //------------------------------------------------------------------------------ 117 | function TREnvironment.GetSymbolNames( 118 | includeSpecialFunctions: LongBool): TArray; 119 | var 120 | Ptr: PSEXPREC; 121 | symbolNames: ICharacterVector; 122 | len: integer; 123 | begin 124 | Ptr := Engine.Rapi.lsInternal(Handle, includeSpecialFunctions); 125 | 126 | symbolNames := TCharacterVector.Create(Engine, Ptr); 127 | len := symbolNames.VectorLength; 128 | SetLength(result, len); 129 | symbolNames.CopyTo(result, len); 130 | end; 131 | //------------------------------------------------------------------------------ 132 | procedure TREnvironment.SetSymbol(symbolName: string; 133 | expression: ISymbolicExpression); 134 | var 135 | installedName: PSEXPREC; 136 | begin 137 | if symbolName = '' then 138 | raise EopaRException.Create('Symbol name cannot be null'); 139 | 140 | if expression = nil then 141 | expression := TSymbolicExpression.Create(Engine, TEngineExtension(Engine).NilValue); 142 | 143 | //if expression.Engine <> self.Engine then { TODO : Engine mismatch } 144 | // raise EopaRException.Create('Engine mismatch'); 145 | 146 | installedName := Engine.Rapi.Install(PAnsiChar(AnsiString(symbolName))); 147 | Engine.Rapi.DefineVar(installedName, expression.Handle, Handle); 148 | end; 149 | 150 | end. 151 | -------------------------------------------------------------------------------- /Src/opaR.LogicalVector.pas: -------------------------------------------------------------------------------- 1 | unit opaR.LogicalVector; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | {$IFDEF MSWINDOWS} 26 | Winapi.Windows, 27 | {$ENDIF} 28 | 29 | Spring.Collections, 30 | 31 | opaR.SEXPREC, 32 | opaR.Utils, 33 | opaR.Interfaces, 34 | opaR.Vector, 35 | opaR.DLLFunctions; 36 | 37 | 38 | type 39 | TLogicalVector = class(TRVector, ILogicalVector) 40 | protected 41 | function GetDataSize: integer; override; 42 | function GetValue(ix: integer): LongBool; override; 43 | procedure SetValue(ix: integer; value: LongBool); override; 44 | public 45 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); overload; 46 | constructor Create(const engine: IREngine; vecLength: integer); overload; 47 | constructor Create(const engine: IREngine; const vector: IEnumerable); overload; 48 | constructor Create(const engine: IREngine; const vector: TArray); overload; 49 | function GetArrayFast: TArray; override; 50 | procedure SetVectorDirect(const values: TArray); override; 51 | end; 52 | 53 | 54 | implementation 55 | 56 | uses 57 | opaR.ProtectedPointer; 58 | 59 | { TLogicalVector } 60 | 61 | //------------------------------------------------------------------------------ 62 | constructor TLogicalVector.Create(const engine: IREngine; vecLength: integer); 63 | begin 64 | // -- The base constructor calls Rf_allocVector 65 | inherited Create(engine, TSymbolicExpressionType.LogicalVector, vecLength); 66 | end; 67 | //------------------------------------------------------------------------------ 68 | constructor TLogicalVector.Create(const engine: IREngine; const vector: IEnumerable); 69 | begin 70 | inherited Create(engine, TSymbolicExpressionType.LogicalVector, vector); 71 | end; 72 | //------------------------------------------------------------------------------ 73 | constructor TLogicalVector.Create(const engine: IREngine; const vector: TArray); 74 | var 75 | pExpr: PSEXPREC; 76 | begin 77 | // -- First get the pointer to the R expression. 78 | pExpr := Engine.Rapi.AllocVector(TSymbolicExpressionType.LogicalVector, Length(vector)); 79 | 80 | Create(engine, pExpr); 81 | 82 | // -- Now copy the array data. 83 | CopyMemory(DataPointer, PLongBool(vector), Length(vector) * DataSize); 84 | end; 85 | //------------------------------------------------------------------------------ 86 | constructor TLogicalVector.Create(const engine: IREngine; pExpr: PSEXPREC); 87 | begin 88 | inherited Create(engine, pExpr); 89 | end; 90 | //------------------------------------------------------------------------------ 91 | function TLogicalVector.GetArrayFast: TArray; 92 | begin 93 | SetLength(result, self.VectorLength); 94 | CopyMemory(PLongBool(result), DataPointer, self.VectorLength * DataSize); 95 | end; 96 | //------------------------------------------------------------------------------ 97 | function TLogicalVector.GetDataSize: integer; 98 | begin 99 | result := SizeOf(LongBool); 100 | end; 101 | //------------------------------------------------------------------------------ 102 | function TLogicalVector.GetValue(ix: integer): LongBool; 103 | var 104 | pp: TProtectedPointer; 105 | PData: PLongBool; 106 | offset: integer; 107 | begin 108 | if (ix < 0) or (ix >= VectorLength) then 109 | raise EopaRException.Create('Error: Vector index out of bounds'); 110 | 111 | pp := TProtectedPointer.Create(self); 112 | try 113 | offset := GetOffset(ix); 114 | PData := PLongBool(NativeInt(DataPointer) + offset); 115 | result := PData^; 116 | finally 117 | pp.Free; 118 | end; 119 | end; 120 | //------------------------------------------------------------------------------ 121 | procedure TLogicalVector.SetValue(ix: integer; value: LongBool); 122 | var 123 | pp: TProtectedPointer; 124 | PData: PLongBool; 125 | offset: integer; 126 | begin 127 | if (ix < 0) or (ix >= VectorLength) then 128 | raise EopaRException.Create('Error: Vector index out of bounds'); 129 | 130 | pp := TProtectedPointer.Create(self); 131 | try 132 | offset := GetOffset(ix); 133 | PData := PLongBool(NativeInt(DataPointer) + offset); 134 | PData^ := value; 135 | finally 136 | pp.Free; 137 | end; 138 | end; 139 | //------------------------------------------------------------------------------ 140 | procedure TLogicalVector.SetVectorDirect(const values: TArray); 141 | begin 142 | // -- Delphi, .NET and R all use contiguous memory blocks for 1D arrays. 143 | CopyMemory(DataPointer, PLongBool(values), Length(values) * DataSize); 144 | end; 145 | 146 | end. 147 | -------------------------------------------------------------------------------- /Tests/opaR.TestUtils.pas: -------------------------------------------------------------------------------- 1 | unit opaR.TestUtils; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Define a class helper for TestFramework.TAbstractTest using the same approach 8 | as in Spring4D (Spring.TestUtils.pas), but with an an extra message parameter 9 | that allows us to compare the exception message to the expected message. 10 | 11 | By checking the exception message we can validate the error message returned 12 | from R (see TEngineExtension.LastErrorMessage). 13 | 14 | -------------------------------------------------------------------------------} 15 | 16 | interface 17 | 18 | uses 19 | System.SysUtils, 20 | System.Math, 21 | System.Classes, 22 | 23 | TestFramework; 24 | 25 | 26 | type 27 | TAbstractTestHelper = class helper for TAbstractTest 28 | public 29 | procedure CheckException(expected: ExceptionClass; method: TProc; 30 | const expectedMsg: string = ''; const msg: string = ''); overload; 31 | end; 32 | 33 | TopaRArrayUtils = class 34 | public 35 | class function GenerateDoubleArray(low, high: integer): TArray; 36 | class function GenerateIntArray(low, high: integer): TArray; 37 | class function DoubleArraysEqual(expectedArray, testArray: TArray): boolean; 38 | class function IntArraysEqual(expectedArray, testArray: TArray): boolean; 39 | class function StringArraysEqual(expectedArray, testArray: TArray): boolean; 40 | class function PrintPairlist: string; 41 | end; 42 | 43 | implementation 44 | 45 | const 46 | epsilon = 0.000000000000005; 47 | 48 | { TAbstractTestHelper } 49 | 50 | //------------------------------------------------------------------------------ 51 | //-- Following code derived from CheckException in Spring.TestUtils.pas 52 | procedure TAbstractTestHelper.CheckException(expected: ExceptionClass; 53 | method: TProc; const expectedMsg: string; const msg: string); 54 | begin 55 | FCheckCalled := True; 56 | try 57 | method; 58 | except 59 | on E: Exception do 60 | begin 61 | if not Assigned(expected) then 62 | raise 63 | else if not E.InheritsFrom(expected) then 64 | FailNotEquals(expected.ClassName, E.ClassName, msg, ReturnAddress) 65 | else 66 | expected := nil; 67 | 68 | // -- opaR-specific code. 69 | if expectedMsg <> '' then 70 | CheckEquals(E.Message, expectedMsg); 71 | end; 72 | end; 73 | 74 | if Assigned(expected) then 75 | FailNotEquals(expected.ClassName, 'nothing', msg, ReturnAddress); 76 | end; 77 | 78 | 79 | { TopaRArrayChecks } 80 | 81 | //------------------------------------------------------------------------------ 82 | class function TopaRArrayUtils.DoubleArraysEqual(expectedArray, 83 | testArray: TArray): boolean; 84 | var 85 | i: integer; 86 | begin 87 | if Length(expectedArray) <> Length(testArray) then 88 | Exit(false); 89 | 90 | result := true; 91 | for i := 0 to Length(expectedArray) - 1 do 92 | if not SameValue(expectedArray[i], testArray[i], epsilon) then Exit(false); 93 | end; 94 | //------------------------------------------------------------------------------ 95 | class function TopaRArrayUtils.GenerateDoubleArray(low, 96 | high: integer): TArray; 97 | var 98 | i: integer; 99 | begin 100 | SetLength(result, high - low + 1); 101 | for i := 0 to high - low do 102 | result[i] := i + low; 103 | end; 104 | //------------------------------------------------------------------------------ 105 | class function TopaRArrayUtils.GenerateIntArray(low, 106 | high: integer): TArray; 107 | var 108 | i: integer; 109 | begin 110 | SetLength(result, high - low + 1); 111 | for i := 0 to high - low do 112 | result[i] := i + low; 113 | end; 114 | //------------------------------------------------------------------------------ 115 | class function TopaRArrayUtils.IntArraysEqual(expectedArray, 116 | testArray: TArray): boolean; 117 | var 118 | i: integer; 119 | begin 120 | if Length(expectedArray) <> Length(testArray) then 121 | Exit(false); 122 | 123 | result := true; 124 | for i := 0 to Length(expectedArray) - 1 do 125 | if not expectedArray[i] = testArray[i] then Exit(false); 126 | end; 127 | //------------------------------------------------------------------------------ 128 | class function TopaRArrayUtils.PrintPairlist: string; 129 | var 130 | defPrintPairlist: TStringList; 131 | begin 132 | defPrintPairlist := TStringList.Create; 133 | defPrintPairlist.Add('printPairList <- function(...) {'); 134 | defPrintPairlist.Add('a <- list(...)'); 135 | defPrintPairlist.Add('namez <- names(a)'); 136 | defPrintPairlist.Add('r <- ' + QuotedStr('')); 137 | defPrintPairlist.Add('if(length(a)==0) return(' + QuotedStr('empty pairlist') + ')'); 138 | defPrintPairlist.Add('for(i in 1:length(a)) {'); 139 | defPrintPairlist.Add('name <- namez[i]'); 140 | defPrintPairlist.Add('r <- paste(r, paste0(name, ' + QuotedStr('=') + ', a[[i]], sep=' + QuotedStr(';') +'))'); 141 | defPrintPairlist.Add('}'); 142 | defPrintPairlist.Add('substring(r, 1, (nchar(r)-1))'); 143 | defPrintPairlist.Add('}'); 144 | 145 | try 146 | result := defPrintPairlist.Text; 147 | finally 148 | defPrintPairlist.Free; 149 | end; 150 | end; 151 | //------------------------------------------------------------------------------ 152 | class function TopaRArrayUtils.StringArraysEqual(expectedArray, 153 | testArray: TArray): boolean; 154 | var 155 | i: integer; 156 | begin 157 | if Length(expectedArray) <> Length(testArray) then 158 | Exit(false); 159 | 160 | result := true; 161 | for i := 0 to Length(expectedArray) - 1 do 162 | if expectedArray[i] <> testArray[i] then Exit(false); 163 | end; 164 | 165 | end. 166 | -------------------------------------------------------------------------------- /Src/opaR.NumericMatrix.pas: -------------------------------------------------------------------------------- 1 | unit opaR.NumericMatrix; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | opaR.Utils, 26 | opaR.Matrix, 27 | opaR.ProtectedPointer, 28 | opaR.Interfaces; 29 | 30 | type 31 | TNumericMatrix = class(TRMatrix, INumericMatrix) 32 | protected 33 | function GetDataSize: integer; override; 34 | function GetValue(rowIndex, columnIndex: integer): double; override; 35 | procedure InitMatrixFastDirect(matrix: TDynMatrix); override; 36 | procedure SetValue(rowIndex, columnIndex: integer; value: double); override; 37 | public 38 | constructor Create(const engine: IREngine; numRows, numCols: integer); overload; 39 | constructor Create(const engine: IREngine; matrix: TDynMatrix); overload; 40 | function GetArrayFast: TDynMatrix; override; 41 | end; 42 | 43 | implementation 44 | 45 | { TNumericMatrix } 46 | 47 | //------------------------------------------------------------------------------ 48 | constructor TNumericMatrix.Create(const engine: IREngine; numRows, 49 | numCols: integer); 50 | begin 51 | inherited Create(engine, TSymbolicExpressionType.NumericVector, numRows, numCols); 52 | end; 53 | //------------------------------------------------------------------------------ 54 | constructor TNumericMatrix.Create(const engine: IREngine; 55 | matrix: TDynMatrix); 56 | begin 57 | inherited Create(engine, TSymbolicExpressionType.NumericVector, matrix); 58 | end; 59 | //------------------------------------------------------------------------------ 60 | function TNumericMatrix.GetArrayFast: TDynMatrix; 61 | var 62 | i: integer; 63 | j: integer; 64 | //vecSize: integer; 65 | //PData: PDouble; 66 | //offset: integer; 67 | begin 68 | SetLength(result, RowCount, ColumnCount); 69 | //vecSize := RowCount * DataSize; 70 | 71 | for i := 0 to RowCount - 1 do 72 | for j := 0 to ColumnCount - 1 do 73 | result[i, j] := GetValue(i, j); 74 | 75 | // -- Different memory layout so can't copy blocks. 76 | {for i := 0 to ColumnCount - 1 do 77 | begin 78 | offset := NativeInt(i * vecSize); 79 | PData := PDouble(NativeInt(DataPointer) + offset); 80 | CopyMemory(PDouble(result[i]), PData, vecSize); 81 | end;} 82 | end; 83 | //------------------------------------------------------------------------------ 84 | function TNumericMatrix.GetDataSize: integer; 85 | begin 86 | result := SizeOf(double); 87 | end; 88 | //------------------------------------------------------------------------------ 89 | function TNumericMatrix.GetValue(rowIndex, columnIndex: integer): double; 90 | var 91 | pp: TProtectedPointer; 92 | PData: PDouble; 93 | offset: integer; 94 | begin 95 | if (rowIndex < 0) or (rowIndex >= RowCount) then 96 | raise EopaRException.Create('Error: row index out of bounds'); 97 | 98 | if (columnIndex < 0) or (columnIndex >= ColumnCount) then 99 | raise EopaRException.Create('Error: column index out of bounds'); 100 | 101 | pp := TProtectedPointer.Create(self); 102 | try 103 | offset := GetOffset(rowIndex, columnIndex); 104 | PData := PDouble(NativeInt(DataPointer) + offset); 105 | result := PData^; 106 | finally 107 | pp.Free; 108 | end; 109 | end; 110 | //------------------------------------------------------------------------------ 111 | procedure TNumericMatrix.InitMatrixFastDirect(matrix: TDynMatrix); 112 | var 113 | numRows: integer; 114 | numCols: integer; 115 | i: integer; 116 | j: integer; 117 | //vecSize: integer; 118 | //PData: PDouble; 119 | //offset: integer; 120 | begin 121 | numRows := Length(matrix); 122 | if numRows <= 0 then 123 | raise EopaRException.Create('Error: Matrix rowCount must be greater than zero'); 124 | 125 | // -- Default memory layout for R is column-major, while Delphi is row-major, 126 | // -- so can't copy blocks. 127 | { TODO : An R matrix can be created as row-major, but need to test for this before copying blocks. } 128 | numCols := Length(matrix[0]); 129 | for i := 0 to numRows - 1 do 130 | for j := 0 to numCols - 1 do 131 | SetValue(i, j, matrix[i, j]); 132 | 133 | // -- Copy each column of the delphi array as a single block. 134 | {vecSize := numRows * DataSize; 135 | for i := 0 to numCols - 1 do 136 | begin 137 | offset := NativeInt(i * vecSize); 138 | PData := PDouble(NativeInt(DataPointer) + offset); 139 | CopyMemory(PData, PDouble(matrix[i]), vecSize); 140 | end;} 141 | end; 142 | //------------------------------------------------------------------------------ 143 | procedure TNumericMatrix.SetValue(rowIndex, columnIndex: integer; 144 | value: double); 145 | var 146 | pp: TProtectedPointer; 147 | PData: PDouble; 148 | offset: integer; 149 | begin 150 | if (rowIndex < 0) or (rowIndex >= RowCount) then 151 | raise EopaRException.Create('Error: row index out of bounds'); 152 | 153 | if (columnIndex < 0) or (columnIndex >= ColumnCount) then 154 | raise EopaRException.Create('Error: column index out of bounds'); 155 | 156 | pp := TProtectedPointer.Create(self); 157 | try 158 | offset := GetOffset(rowIndex, columnIndex); 159 | PData := PDouble(NativeInt(DataPointer) + offset); 160 | PData^ := value; 161 | finally 162 | pp.Free; 163 | end; 164 | end; 165 | 166 | end. 167 | -------------------------------------------------------------------------------- /Src/opaR.Factor.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Factor; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | The port of the Factor type from R.NET is complicated by two Delphi limitations: 25 | 26 | 1. No RTTI for explicitly-numbered enum types (i.e. initialised enums). 27 | 2. No parameterised interface methods. 28 | 29 | These impact on the GetFactors method: For #1 we need to enforce 30 | the use of non-initialised enums, and for #2 we can just cast to TFactor from 31 | IFactor when calling the method. Enforcement of non-initialised enums isn't a 32 | problem in practice (with respect to using R). 33 | 34 | -------------------------------------------------------------------------------} 35 | 36 | interface 37 | 38 | uses 39 | System.Rtti, 40 | System.TypInfo, 41 | 42 | opaR.SEXPREC, 43 | opaR.Utils, 44 | opaR.DLLFunctions, 45 | opaR.IntegerVector, 46 | opaR.Interfaces; 47 | 48 | type 49 | TFactor = class(TIntegerVector, IFactor) 50 | private 51 | function GetIsOrdered: boolean; 52 | public 53 | function GetFactor(index: integer): string; 54 | function GetFactors: TArray; overload; 55 | function GetFactors(ignoreCase: boolean = false): TArray; overload; 56 | function GetLevels: TArray; 57 | procedure SetFactor(index: integer; factorValue: string); 58 | property IsOrdered: boolean read GetIsOrdered; 59 | end; 60 | 61 | implementation 62 | 63 | uses 64 | opaR.EngineExtension, 65 | opaR.SymbolicExpression; 66 | 67 | 68 | { TFactor } 69 | 70 | //------------------------------------------------------------------------------ 71 | function TFactor.GetFactor(index: integer): string; 72 | var 73 | intValue: integer; 74 | begin 75 | intValue := self[index]; 76 | if intValue <= 0 then 77 | result := '' 78 | else 79 | result := GetLevels[intValue - 1]; // -- zero-based index in Delphi, but 1-based in R. 80 | end; 81 | //------------------------------------------------------------------------------ 82 | function TFactor.GetFactors: TArray; 83 | var 84 | i: integer; 85 | levels: TArray; 86 | levelIndices: TArray; 87 | begin 88 | levels := GetLevels; 89 | levelIndices := GetArrayFast; 90 | SetLength(result, VectorLength); 91 | for i := 0 to VectorLength - 1 do 92 | if levelIndices[i] = NACode then 93 | result[i] := '' 94 | else 95 | result[i] := levels[levelIndices[i] - 1]; // -- zero-based index in Delphi, but 1-based in R. 96 | end; 97 | //------------------------------------------------------------------------------ 98 | function TFactor.GetFactors(ignoreCase: boolean): TArray; 99 | var 100 | i: integer; 101 | typeInf: PTypeInfo; 102 | levels: TArray; 103 | intValue: integer; 104 | strValue: string; 105 | begin 106 | typeInf := PTypeInfo(TypeInfo(TEnum)); 107 | 108 | if (typeInf = nil) then 109 | raise EopaRException.Create('Error: Only enumerated types with default values are supported'); 110 | 111 | if (typeInf^.Kind <> tkEnumeration) then 112 | raise EopaRException.Create('Error: Only enumerated types are supported'); 113 | 114 | levels := GetLevels; 115 | SetLength(result, VectorLength); 116 | 117 | for i := 0 to VectorLength - 1 do 118 | begin 119 | intValue := self[i]; 120 | strValue := levels[intValue - 1]; 121 | // -- Now convert the string to the corresponding enum. 122 | // -- From http://stackoverflow.com/questions/31601707/generic-functions-for-converting-an-enumeration-to-string-and-back 123 | case GetTypeData(typeInf)^.OrdType of 124 | otSByte, otUByte: 125 | PByte(@result[i])^ := GetEnumValue(typeInf, strValue); 126 | otSWord, otUWord: 127 | PWord(@result[i])^ := GetEnumValue(typeInf, strValue); 128 | otSLong, otULong: 129 | PCardinal(@result[i])^ := GetEnumValue(typeInf, strValue); 130 | end; 131 | end; 132 | end; 133 | //------------------------------------------------------------------------------ 134 | function TFactor.GetIsOrdered: boolean; 135 | begin 136 | result := Engine.Rapi.IsOrdered(Handle); 137 | end; 138 | //------------------------------------------------------------------------------ 139 | function TFactor.GetLevels: TArray; 140 | var 141 | expr: ISymbolicExpression; 142 | attr: ISymbolicExpression; 143 | begin 144 | expr := TEngineExtension(Engine).GetPredefinedSymbol('R_LevelsSymbol'); 145 | attr := GetAttribute(expr); 146 | 147 | result := attr.AsCharacter.ToArray; 148 | end; 149 | //------------------------------------------------------------------------------ 150 | procedure TFactor.SetFactor(index: integer; factorValue: string); 151 | var 152 | i: integer; 153 | factIndex: integer; 154 | levels: TArray; 155 | begin 156 | factIndex := -1; 157 | 158 | if factorValue = '' then 159 | self[index] := NACode 160 | else 161 | begin 162 | levels := GetLevels; 163 | for i := 0 to Length(levels) - 1 do 164 | begin 165 | if factorValue = levels[i] then 166 | begin 167 | factIndex := i; 168 | break; 169 | end; 170 | end; 171 | 172 | if factIndex >= 0 then 173 | self[index] := factIndex + 1 // -- zero-based index in Delphi, but 1-based in R. 174 | else 175 | self[index] := NACode; 176 | end; 177 | end; 178 | 179 | end. 180 | -------------------------------------------------------------------------------- /Src/opaR.PairList.pas: -------------------------------------------------------------------------------- 1 | unit opaR.PairList; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | This is a wrapper class for a PairList created by a call to Rf_VectorToPairList. 25 | Early versions of R exposed PairLists more extensively - now they are rarely 26 | encountered by users. 27 | 28 | Pairlists in R are stored as a chain of nodes, where each node points to the 29 | location of the next node in the chain, in addition to the node's contents and 30 | the node's "name". 31 | 32 | -------------------------------------------------------------------------------} 33 | 34 | interface 35 | 36 | uses 37 | Generics.Tuples, // from https://github.com/malcolmgroves/generics.tuples 38 | 39 | opaR.VectorUtils, 40 | opaR.DLLFunctions, 41 | opaR.Utils, 42 | opaR.SEXPREC, 43 | opaR.Symbol, 44 | opaR.SymbolicExpression, 45 | opaR.Interfaces; 46 | 47 | type 48 | TPairList = class(TSymbolicExpression, IPairList, IVectorEnumerable) 49 | private 50 | type 51 | TEnumerator = class(TInterfacedObject, IVectorEnumerator) 52 | private 53 | FIndex: integer; 54 | FPairList: TPairList; 55 | FCurrentNode: TSEXPREC; 56 | function GetCurrent: ISymbol; 57 | public 58 | constructor Create(const pairList: TPairList); 59 | function MoveNext: Boolean; 60 | property Current: ISymbol read GetCurrent; 61 | end; 62 | private 63 | function GetCount: integer; 64 | public 65 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); 66 | function First: ISymbol; 67 | function GetEnumerator: IVectorEnumerator; 68 | function ToArray: TArray; 69 | function ToTupleArray: TArray>; 70 | property Count: integer read GetCount; 71 | end; 72 | 73 | implementation 74 | 75 | uses 76 | opaR.EngineExtension; 77 | 78 | { TPairList } 79 | 80 | //------------------------------------------------------------------------------ 81 | constructor TPairList.Create(const engine: IREngine; pExpr: PSEXPREC); 82 | begin 83 | // -- The pExpr is that returned from a call to Rf_VectorToPairList in the calling code. 84 | inherited Create(engine, pExpr); 85 | end; 86 | //------------------------------------------------------------------------------ 87 | function TPairList.First: ISymbol; 88 | begin 89 | result := TSymbol.Create(Engine, Handle.listsxp.tagval); 90 | end; 91 | //------------------------------------------------------------------------------ 92 | /// 93 | /// This returns the number of nodes. 94 | /// 95 | function TPairList.GetCount: integer; 96 | begin 97 | result := Engine.Rapi.Length(Handle); 98 | end; 99 | //------------------------------------------------------------------------------ 100 | function TPairList.GetEnumerator: IVectorEnumerator; 101 | begin 102 | result := TEnumerator.Create(self); 103 | end; 104 | //------------------------------------------------------------------------------ 105 | /// 106 | /// opaR method - Not in R.NET 1.6.5 107 | /// 108 | function TPairList.ToTupleArray: TArray>; 109 | var 110 | i: integer; 111 | expr: TSEXPREC; 112 | begin 113 | SetLength(result, self.Count); 114 | expr := Handle.listsxp.cdrval^; 115 | result[0] := TTuple.Create(TSymbol.Create(Engine, Handle.listsxp.tagval), TSymbolicExpression.Create(Engine, Handle.listsxp.carval)); 116 | 117 | for i := 1 to self.Count - 1 do 118 | begin 119 | result[i] := TTuple.Create(TSymbol.Create(Engine, expr.listsxp.tagval), TSymbolicExpression.Create(Engine, expr.listsxp.carval)); 120 | expr := expr.listsxp.cdrval^; 121 | end; 122 | end; 123 | //------------------------------------------------------------------------------ 124 | /// 125 | /// opaR method - Not in R.NET 1.6.5 126 | /// 127 | function TPairList.ToArray: TArray; 128 | var 129 | i: integer; 130 | expr: TSEXPREC; 131 | begin 132 | SetLength(result, self.Count); 133 | expr := Handle.listsxp.cdrval^; 134 | result[0] := TSymbol.Create(Engine, Handle.listsxp.tagval); 135 | 136 | for i := 1 to self.Count - 1 do 137 | begin 138 | result[i] := TSymbol.Create(Engine, expr.listsxp.tagval); 139 | expr := expr.listsxp.cdrval^; 140 | end; 141 | end; 142 | 143 | 144 | 145 | { TPairList.TEnumerator } 146 | 147 | //------------------------------------------------------------------------------ 148 | constructor TPairList.TEnumerator.Create(const pairList: TPairList); 149 | begin 150 | FIndex := -1; 151 | FPairList := pairList; 152 | end; 153 | //------------------------------------------------------------------------------ 154 | function TPairList.TEnumerator.GetCurrent: ISymbol; 155 | begin 156 | result := TSymbol.Create(FPairList.Engine, FCurrentNode.listsxp.tagval); 157 | end; 158 | //------------------------------------------------------------------------------ 159 | function TPairList.TEnumerator.MoveNext: Boolean; 160 | begin 161 | result := FIndex < FPairList.Count - 1; 162 | if result then 163 | begin 164 | if FIndex = -1 then 165 | FCurrentNode := FPairList.Handle^ 166 | else if (FCurrentNode.sxpinfo.type_ <> Ord(TSymbolicExpressionType.Null)) then 167 | FCurrentNode := FCurrentNode.listsxp.cdrval^; 168 | Inc(FIndex); 169 | //Ptr := FCurrentNode.listsxp.carval; 170 | end; 171 | end; 172 | 173 | end. 174 | -------------------------------------------------------------------------------- /Src/opaR.RawVector.pas: -------------------------------------------------------------------------------- 1 | unit opaR.RawVector; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | {$IFDEF MSWINDOWS} 26 | Winapi.Windows, 27 | {$ENDIF} 28 | System.Types, 29 | 30 | Spring.Collections, 31 | 32 | opaR.Interfaces, 33 | opaR.SEXPREC, 34 | opaR.Utils, 35 | opaR.DLLFunctions, 36 | opaR.Vector, 37 | opaR.ProtectedPointer; 38 | 39 | type 40 | TRawVector = class(TRVector, IRawVector) 41 | protected 42 | function GetDataSize: integer; override; 43 | function GetValue(ix: integer): Byte; override; 44 | procedure SetValue(ix: integer; value: Byte); override; 45 | public 46 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); overload; 47 | constructor Create(const engine: IREngine; vecLength: integer); overload; 48 | constructor Create(const engine: IREngine; const vector: IEnumerable); overload; 49 | constructor Create(const engine: IREngine; const vector: TArray); overload; 50 | function GetArrayFast: TArray; override; 51 | procedure CopyTo(const destination: TArray; copyCount: integer; sourceIndex: integer = 0; destinationIndex: integer = 0); //override; 52 | procedure SetVectorDirect(const values: TArray); override; 53 | end; 54 | 55 | implementation 56 | 57 | { TRawVector } 58 | 59 | //------------------------------------------------------------------------------ 60 | procedure TRawVector.CopyTo(const destination: TArray; copyCount, 61 | sourceIndex, destinationIndex: integer); 62 | var 63 | offset: integer; 64 | PData: PByte; 65 | PDestination: PByte; 66 | begin 67 | if destination = nil then 68 | raise EopaRException.Create('Error: Destination array cannot be nil'); 69 | 70 | if (copyCount <= 0) then 71 | raise EopaRException.Create('Error: Number of elements to copy must be > 0'); 72 | 73 | if (sourceIndex < 0) or (VectorLength < sourceIndex + copyCount) then 74 | raise EopaRException.Create('Error: Source array index out of bounds'); 75 | 76 | if (destinationIndex < 0) or (Length(destination) < destinationIndex + copyCount) then 77 | raise EopaRException.Create('Error: Destination array index out of bounds'); 78 | 79 | offset := GetOffset(sourceIndex); 80 | PData := PByte(NativeInt(DataPointer) + offset); 81 | PDestination := PByte(NativeInt(PByte(destination)) + destinationIndex * SizeOf(Byte)); 82 | CopyMemory(PDestination, PData, copyCount * DataSize); 83 | end; 84 | //------------------------------------------------------------------------------ 85 | constructor TRawVector.Create(const engine: IREngine; pExpr: PSEXPREC); 86 | begin 87 | inherited Create(engine, pExpr); 88 | end; 89 | //------------------------------------------------------------------------------ 90 | constructor TRawVector.Create(const engine: IREngine; vecLength: integer); 91 | begin 92 | inherited Create(engine, TSymbolicExpressionType.RawVector, vecLength); 93 | end; 94 | //------------------------------------------------------------------------------ 95 | constructor TRawVector.Create(const engine: IREngine; const vector: TArray); 96 | var 97 | pExpr: PSEXPREC; 98 | begin 99 | // -- First get the pointer to the R expression. 100 | pExpr := Engine.Rapi.AllocVector(TSymbolicExpressionType.RawVector, Length(vector)); 101 | 102 | Create(engine, pExpr); 103 | 104 | // -- Now copy the array data. 105 | CopyMemory(DataPointer, PByte(vector), Length(vector) * DataSize); 106 | end; 107 | //------------------------------------------------------------------------------ 108 | constructor TRawVector.Create(const engine: IREngine; 109 | const vector: IEnumerable); 110 | begin 111 | inherited Create(engine, TSymbolicExpressionType.RawVector, vector); 112 | end; 113 | //------------------------------------------------------------------------------ 114 | function TRawVector.GetArrayFast: TArray; 115 | begin 116 | SetLength(result, self.VectorLength); 117 | CopyMemory(PByte(result), DataPointer, self.VectorLength * DataSize); 118 | end; 119 | //------------------------------------------------------------------------------ 120 | function TRawVector.GetDataSize: integer; 121 | begin 122 | result := SizeOf(Byte); 123 | end; 124 | //------------------------------------------------------------------------------ 125 | function TRawVector.GetValue(ix: integer): Byte; 126 | var 127 | pp: TProtectedPointer; 128 | PData: PByte; 129 | offset: integer; 130 | begin 131 | if (ix < 0) or (ix >= VectorLength) then 132 | raise EopaRException.Create('Error: Vector index out of bounds'); 133 | 134 | pp := TProtectedPointer.Create(self); 135 | try 136 | offset := GetOffset(ix); 137 | PData := PByte(NativeInt(DataPointer) + offset); 138 | result := PData^; 139 | finally 140 | pp.Free; 141 | end; 142 | end; 143 | //------------------------------------------------------------------------------ 144 | procedure TRawVector.SetValue(ix: integer; value: Byte); 145 | var 146 | pp: TProtectedPointer; 147 | PData: PByte; 148 | offset: integer; 149 | begin 150 | if (ix < 0) or (ix >= VectorLength) then 151 | raise EopaRException.Create('Error: Vector index out of bounds'); 152 | 153 | pp := TProtectedPointer.Create(self); 154 | try 155 | offset := GetOffset(ix); 156 | PData := PByte(NativeInt(DataPointer) + offset); 157 | PData^ := value; 158 | finally 159 | pp.Free; 160 | end; 161 | end; 162 | //------------------------------------------------------------------------------ 163 | procedure TRawVector.SetVectorDirect(const values: TArray); 164 | begin 165 | CopyMemory(DataPointer, PByte(values), Length(values) * DataSize); 166 | end; 167 | 168 | end. 169 | -------------------------------------------------------------------------------- /Src/opaR.CharacterMatrix.pas: -------------------------------------------------------------------------------- 1 | unit opaR.CharacterMatrix; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | opaR.SEXPREC, 26 | opaR.VECTOR_SEXPREC, 27 | opaR.Utils, 28 | opaR.DLLFunctions, 29 | opaR.Matrix, 30 | opaR.ProtectedPointer, 31 | opaR.Interfaces; 32 | 33 | type 34 | TCharacterMatrix = class(TRMatrix, ICharacterMatrix) 35 | private 36 | function mkChar(s: string): PSEXPREC; 37 | protected 38 | function GetDataSize: integer; override; 39 | function GetValue(rowIndex, columnIndex: integer): string; override; 40 | procedure InitMatrixFastDirect(matrix: TDynMatrix); override; 41 | procedure SetValue(rowIndex, columnIndex: integer; value: string); override; 42 | public 43 | constructor Create(const engine: IREngine; numRows, numCols: integer); overload; 44 | constructor Create(const engine: IREngine; matrix: TDynMatrix); overload; 45 | function GetArrayFast: TDynMatrix; override; 46 | end; 47 | 48 | implementation 49 | 50 | uses 51 | opaR.EngineExtension; 52 | 53 | { TCharacterMatrix } 54 | 55 | //------------------------------------------------------------------------------ 56 | constructor TCharacterMatrix.Create(const engine: IREngine; numRows, 57 | numCols: integer); 58 | begin 59 | inherited Create(engine, TSymbolicExpressionType.CharacterVector, numRows, numCols); 60 | end; 61 | //------------------------------------------------------------------------------ 62 | constructor TCharacterMatrix.Create(const engine: IREngine; 63 | matrix: TDynMatrix); 64 | begin 65 | inherited Create(engine, TSymbolicExpressionType.CharacterVector, matrix); 66 | end; 67 | //------------------------------------------------------------------------------ 68 | function TCharacterMatrix.GetArrayFast: TDynMatrix; 69 | var 70 | i: integer; 71 | j: integer; 72 | begin 73 | SetLength(result, RowCount, ColumnCount); 74 | 75 | for i := 0 to RowCount - 1 do 76 | for j := 0 to ColumnCount - 1 do 77 | result[i, j] := GetValue(i, j); 78 | end; 79 | //------------------------------------------------------------------------------ 80 | function TCharacterMatrix.GetDataSize: integer; 81 | begin 82 | result := SizeOf(PSEXPREC); 83 | end; 84 | //------------------------------------------------------------------------------ 85 | function TCharacterMatrix.GetValue(rowIndex, columnIndex: integer): string; 86 | var 87 | offset: integer; 88 | PPtr: PSEXPREC; 89 | PData: PSEXPREC; 90 | pp: TProtectedPointer; 91 | ix: integer; 92 | begin 93 | if (rowIndex < 0) or (rowIndex >= RowCount) then 94 | raise EopaRException.Create('Error: row index out of bounds'); 95 | 96 | if (columnIndex < 0) or (columnIndex >= ColumnCount) then 97 | raise EopaRException.Create('Error: column index out of bounds'); 98 | 99 | pp := TProtectedPointer.Create(self); 100 | try 101 | // -- Each string is stored in a global pool of C-style strings, and the 102 | // -- parent vector is an array of CHARSXP pointers to those strings. 103 | { TODO : ix will be dependent on whether the matrix is stored row or column-major? Check this. } 104 | ix := columnIndex * RowCount + rowIndex; 105 | PPtr := PSEXPREC(PPointerArray(DataPointer)^[ix]); 106 | 107 | if (PPtr = TEngineExtension(Engine).NAStringPointer) or (PPtr = nil) then 108 | result := '' 109 | else 110 | begin 111 | // -- At this point we have a pointer to the character vector, so we now 112 | // -- need to offset by the TVECTOR_SEXPREC header size to get the pointer 113 | // -- to the string. 114 | offset := SizeOf(TVECTOR_SEXPREC); 115 | PData := PSEXPREC(NativeInt(PPtr) + offset); 116 | 117 | result := String(AnsiString(PAnsiChar(PData))); 118 | end; 119 | finally 120 | pp.Free; 121 | end; 122 | end; 123 | //------------------------------------------------------------------------------ 124 | procedure TCharacterMatrix.InitMatrixFastDirect(matrix: TDynMatrix); 125 | var 126 | numRows: integer; 127 | numCols: integer; 128 | i: integer; 129 | j: integer; 130 | begin 131 | numRows := Length(matrix); 132 | if numRows <= 0 then 133 | raise EopaRException.Create('Error: Matrix rowCount must be greater than zero'); 134 | 135 | numCols := Length(matrix[0]); 136 | for i := 0 to numRows - 1 do 137 | for j := 0 to numCols - 1 do 138 | SetValue(i, j, matrix[i, j]); 139 | end; 140 | //------------------------------------------------------------------------------ 141 | function TCharacterMatrix.mkChar(s: string): PSEXPREC; 142 | begin 143 | // -- The call to Rf_mkChar gets us a CHARSXP, either from R's global cache 144 | // -- or by creating a new one. 145 | result := Engine.Rapi.MakeChar(PAnsiChar(AnsiString(s))); 146 | end; 147 | //------------------------------------------------------------------------------ 148 | procedure TCharacterMatrix.SetValue(rowIndex, columnIndex: integer; 149 | value: string); 150 | var 151 | PData: PSEXPREC; 152 | pp: TProtectedPointer; 153 | ix: integer; 154 | begin 155 | if (rowIndex < 0) or (rowIndex >= RowCount) then 156 | raise EopaRException.Create('Error: row index out of bounds'); 157 | 158 | if (columnIndex < 0) or (columnIndex >= ColumnCount) then 159 | raise EopaRException.Create('Error: column index out of bounds'); 160 | 161 | pp := TProtectedPointer.Create(self); 162 | try 163 | if value = '' then 164 | PData := TEngineExtension(Engine).NAStringPointer 165 | else 166 | PData := mkChar(value); 167 | 168 | ix := columnIndex * RowCount + rowIndex; 169 | PPointerArray(DataPointer)^[ix] := PData; 170 | finally 171 | pp.Free; 172 | end; 173 | end; 174 | 175 | end. 176 | -------------------------------------------------------------------------------- /Src/Devices/opaR.Devices.NullCharacterDevice.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Devices.NullCharacterDevice; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | System.Types, 26 | 27 | opaR.Utils, 28 | opaR.Interfaces; 29 | 30 | type 31 | TNullCharacterDevice = class(TInterfacedObject, ICharacterDevice) 32 | public 33 | function ReadConsole(prompt: string; capacity: integer; history: boolean): string; 34 | procedure WriteConsole(output: string; length: integer; outputType: TConsoleOutputType); 35 | procedure ShowMessage(msg: string); 36 | procedure Busy(which: TBusyType); 37 | procedure Callback; 38 | function Ask(question: string): TYesNoCancel; 39 | // -- Unix-only from this point. 40 | procedure Suicide(msg: string); 41 | procedure ResetConsole; 42 | procedure FlushConsole; 43 | procedure ClearErrorConsole; 44 | procedure CleanUp(saveAction: TStartupSaveAction; status: integer; runLast: boolean); 45 | function ShowFiles(files, headers: TArray; title: string; delete: boolean; pager: string): boolean; 46 | function ChooseFile(create: boolean): string; 47 | procedure EditFile(fileName: string); 48 | function LoadHistory(call: IRLanguage; operation: ISymbolicExpression; args: IPairlist; environment: IREnvironment): ISymbolicExpression; 49 | function SaveHistory(call: IRLanguage; operation: ISymbolicExpression; args: IPairlist; environment: IREnvironment): ISymbolicExpression; 50 | function AddHistory(call: IRLanguage; operation: ISymbolicExpression; args: IPairlist; environment: IREnvironment): ISymbolicExpression; 51 | // -- End Unix-only 52 | end; 53 | 54 | implementation 55 | 56 | uses 57 | opaR.EngineExtension; 58 | 59 | { TNullCharacterDevice } 60 | 61 | //------------------------------------------------------------------------------ 62 | function TNullCharacterDevice.AddHistory(call: IRLanguage; 63 | operation: ISymbolicExpression; args: IPairlist; 64 | environment: IREnvironment): ISymbolicExpression; 65 | begin 66 | result := TEngineExtension(environment.Engine).NilValueExpression; 67 | end; 68 | //------------------------------------------------------------------------------ 69 | function TNullCharacterDevice.Ask(question: string): TYesNoCancel; 70 | begin 71 | result := TYesNoCancel.Cancel; // -- The default value. 72 | end; 73 | //------------------------------------------------------------------------------ 74 | procedure TNullCharacterDevice.Busy(which: TBusyType); 75 | begin 76 | // -- Do nothing. 77 | end; 78 | //------------------------------------------------------------------------------ 79 | procedure TNullCharacterDevice.Callback; 80 | begin 81 | // -- Do nothing. 82 | end; 83 | //------------------------------------------------------------------------------ 84 | function TNullCharacterDevice.ChooseFile(create: boolean): string; 85 | begin 86 | result := ''; 87 | end; 88 | //------------------------------------------------------------------------------ 89 | procedure TNullCharacterDevice.CleanUp(saveAction: TStartupSaveAction; 90 | status: integer; runLast: boolean); 91 | begin 92 | // -- Do nothing. 93 | end; 94 | //------------------------------------------------------------------------------ 95 | procedure TNullCharacterDevice.ClearErrorConsole; 96 | begin 97 | // -- Do nothing. 98 | end; 99 | //------------------------------------------------------------------------------ 100 | procedure TNullCharacterDevice.EditFile(fileName: string); 101 | begin 102 | // -- Do nothing. 103 | end; 104 | //------------------------------------------------------------------------------ 105 | procedure TNullCharacterDevice.FlushConsole; 106 | begin 107 | // -- Do nothing. 108 | end; 109 | //------------------------------------------------------------------------------ 110 | function TNullCharacterDevice.LoadHistory(call: IRLanguage; 111 | operation: ISymbolicExpression; args: IPairlist; 112 | environment: IREnvironment): ISymbolicExpression; 113 | begin 114 | result := TEngineExtension(environment.Engine).NilValueExpression; 115 | end; 116 | //------------------------------------------------------------------------------ 117 | function TNullCharacterDevice.ReadConsole(prompt: string; capacity: integer; 118 | history: boolean): string; 119 | begin 120 | result := ''; 121 | end; 122 | //------------------------------------------------------------------------------ 123 | procedure TNullCharacterDevice.ResetConsole; 124 | begin 125 | // -- Do nothing. 126 | end; 127 | //------------------------------------------------------------------------------ 128 | function TNullCharacterDevice.SaveHistory(call: IRLanguage; 129 | operation: ISymbolicExpression; args: IPairlist; 130 | environment: IREnvironment): ISymbolicExpression; 131 | begin 132 | result := TEngineExtension(environment.Engine).NilValueExpression; 133 | end; 134 | //------------------------------------------------------------------------------ 135 | function TNullCharacterDevice.ShowFiles(files, headers: TArray; 136 | title: string; delete: boolean; pager: string): boolean; 137 | begin 138 | result := false; 139 | end; 140 | //------------------------------------------------------------------------------ 141 | procedure TNullCharacterDevice.ShowMessage(msg: string); 142 | begin 143 | // -- Do nothing. 144 | end; 145 | //------------------------------------------------------------------------------ 146 | procedure TNullCharacterDevice.Suicide(msg: string); 147 | begin 148 | // -- Do nothing. 149 | end; 150 | //------------------------------------------------------------------------------ 151 | procedure TNullCharacterDevice.WriteConsole(output: string; length: integer; 152 | outputType: TConsoleOutputType); 153 | begin 154 | // -- Do nothing. 155 | end; 156 | 157 | 158 | end. 159 | -------------------------------------------------------------------------------- /Src/opaR.Utils.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Utils; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | System.SysUtils, 26 | System.Types; 27 | 28 | type 29 | TPAnsiCharArray = array of PAnsiChar; 30 | PPAnsiCharArray = ^TPAnsiCharArray; 31 | 32 | EopaRException = class(Exception); 33 | 34 | TDynMatrix = array of TArray; 35 | 36 | // -- C and C++ libraries, usually store enumerated types as words or double words. 37 | // -- Use the {$MINENUMSIZE 4} directive to store the TSymbolicExpressionType 38 | // -- enumeration type as an unsigned double-word. {$Z4} in older Delphi versions. 39 | {$MINENUMSIZE 4} 40 | 41 | TSymbolicExpressionType = ( 42 | Null = 0, // -- Null. 43 | Symbol = 1, // -- Symbols. 44 | Pairlist = 2, // -- Pairlists. 45 | Closure = 3, // -- Closures. 46 | Environment = 4, // -- Environments. 47 | Promise = 5, // -- To be evaluated. 48 | LanguageObject = 6, // -- Pairlists for function calls. 49 | SpecialFunction = 7, // -- Special functions. 50 | BuiltinFunction = 8, // -- Builtin functions. 51 | InternalCharacterString = 9, // -- Internal character string. (CHARSXP) 52 | LogicalVector = 10, // -- Boolean vectors. 53 | IntegerVector = 13, // -- Integer vectors. 54 | NumericVector = 14, // -- Numeric vectors. 55 | ComplexVector = 15, // -- Complex number vectors. 56 | CharacterVector = 16, // -- Character vectors. 57 | DotDotDotObject = 17, // -- Dot-dot-dot object. 58 | Any = 18, // -- Place holders for any type. 59 | List = 19, // -- Generic vectors. 60 | ExpressionVector = 20, // -- Expression vectors. 61 | ByteCode = 21, // -- Byte code. 62 | ExternalPointer = 22, // -- External pointer. 63 | WeakReference = 23, // -- Weak reference. 64 | RawVector = 24, // -- Raw vectors. 65 | S4 = 25); // -- S4 classes. 66 | 67 | TStartupRestoreAction = ( 68 | NoRestore = 0, 69 | Restore = 1, 70 | Default = 2); 71 | 72 | TStartupSaveAction = ( 73 | Default_ = 2, { TODO : Can we define same name for different enums? } 74 | NoSave = 3, 75 | Save = 4, 76 | Ask = 5, 77 | Suicide = 6); 78 | 79 | TYesNoCancel = ( 80 | Yes = 1, 81 | No = 2, 82 | Cancel = 0); 83 | 84 | TBusyType = ( 85 | None = 0, 86 | ExtendedComputation = 1); 87 | 88 | TConsoleOutputType = (None_ = 0); 89 | 90 | TUiMode = ( 91 | RGui, 92 | RTerminal, 93 | LinkDll); 94 | 95 | TParseStatus = ( 96 | Null_, 97 | OK, 98 | Incomplete, 99 | Error, 100 | EOF); 101 | 102 | {$MINENUMSIZE 1} // -- Restore the default enum size. 103 | 104 | 105 | // -- See http://praxis-velthuis.de/rdc/articles/articles-convert.html#propertyindex 106 | // -- for details on the bit field implementation. 107 | // -- Note that for type_ we're using an integer so will need to cast to TSymbolicExpressionType. 108 | Tsxpinfo = packed record 109 | private 110 | Flags: DWord; 111 | {$IFDEF CPUX64} // -- SizeOf(VECTOR_SEXPREC) in R.NET x64 = 40 112 | Pad: array[0..3] of byte; 113 | {$ENDIF} 114 | function GetBits(const aIndex: Integer): Integer; 115 | procedure SetBits(const aIndex: Integer; const aValue: Integer); 116 | public 117 | property type_: Integer index $0005 read GetBits write SetBits; // 5 bits at offset 0 (TSymbolicExpressionType) 118 | property obj: Integer index $0501 read GetBits write SetBits; // 1 bit at offset 5 ($05) 119 | property named: Integer index $0602 read GetBits write SetBits; // 2 bits at offset 6 ($06) 120 | property gp: Integer index $0810 read GetBits write SetBits; // 16 bits at offset 8 ($08) 121 | property mark: Integer index $1801 read GetBits write SetBits; // 1 bit at offset 24 ($18) 122 | property debug: Integer index $1901 read GetBits write SetBits; // 1 bit at offset 25 ($19) 123 | property trace: Integer index $1A01 read GetBits write SetBits; // 1 bit at offset 26 ($1A) 124 | property spare: Integer index $1B01 read GetBits write SetBits; // 1 bit at offset 27 ($1B) 125 | property gcgen: Integer index $1C01 read GetBits write SetBits; // 1 bit at offset 28 ($1C) 126 | property gccls: Integer index $1D03 read GetBits write SetBits; // 3 bits at offset 29 ($18) 127 | end; 128 | 129 | 130 | 131 | implementation 132 | 133 | //------------------------------------------------------------------------------ 134 | function GetDWordBits(const Bits: DWORD; const aIndex: Integer): Integer; 135 | begin 136 | Result := (Bits shr (aIndex shr 8)) // offset 137 | and ((1 shl Byte(aIndex)) - 1); // mask 138 | end; 139 | //------------------------------------------------------------------------------ 140 | procedure SetDWordBits(var Bits: DWORD; const aIndex: Integer; const aValue: Integer); 141 | var 142 | Offset: Byte; 143 | Mask: Integer; 144 | begin 145 | Mask := ((1 shl Byte(aIndex)) - 1); 146 | Assert(aValue <= Mask); 147 | 148 | Offset := aIndex shr 8; 149 | Bits := (Bits and (not (Mask shl Offset))) 150 | or DWORD(aValue shl Offset); 151 | end; 152 | //------------------------------------------------------------------------------ 153 | 154 | 155 | 156 | { Tsxpinfo } 157 | 158 | //------------------------------------------------------------------------------ 159 | function Tsxpinfo.GetBits(const aIndex: Integer): Integer; 160 | begin 161 | result := GetDWordBits(Flags, aIndex); 162 | end; 163 | //------------------------------------------------------------------------------ 164 | procedure Tsxpinfo.SetBits(const aIndex, aValue: Integer); 165 | begin 166 | SetDWordBits(Flags, aIndex, aValue); 167 | end; 168 | 169 | end. 170 | -------------------------------------------------------------------------------- /Src/Devices/opaR.Devices.ConsoleDevice.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Devices.ConsoleDevice; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | NOTE: Use of a standard ConsoleDevice requires there to be an active Console, 25 | which is obviously the case if the application has been created as a console 26 | app. For GUI apps in debug mode, go to Project Options and under Linking select 27 | "Generate console application" as TRUE. This will create a console window in 28 | conjunction with the GUI. 29 | 30 | -------------------------------------------------------------------------------} 31 | 32 | { TODO : TConsoleDevice - Unix functions. } 33 | 34 | interface 35 | 36 | uses 37 | Winapi.Windows, 38 | System.SysUtils, 39 | System.Types, 40 | 41 | opaR.Utils, 42 | opaR.Interfaces; 43 | 44 | type 45 | TConsoleDevice = class(TInterfacedObject, ICharacterDevice) 46 | public 47 | function ReadConsole(prompt: string; capacity: integer; history: boolean): string; 48 | procedure WriteConsole(output: string; length: integer; outputType: TConsoleOutputType); 49 | procedure ShowMessage(msg: string); 50 | procedure Busy(which: TBusyType); 51 | procedure Callback; 52 | function Ask(question: string): TYesNoCancel; 53 | // -- Unix-only from this point. 54 | procedure Suicide(msg: string); 55 | procedure ResetConsole; 56 | procedure FlushConsole; 57 | procedure ClearErrorConsole; 58 | procedure CleanUp(saveAction: TStartupSaveAction; status: integer; runLast: boolean); 59 | function ShowFiles(files, headers: TArray; title: string; delete: boolean; pager: string): boolean; 60 | function ChooseFile(create: boolean): string; 61 | procedure EditFile(fileName: string); 62 | //SymbolicExpression LoadHistory(Language call, SymbolicExpression operation, Pairlist args, REnvironment environment); 63 | //function LoadHistory: TSymbolicExpression; 64 | //SymbolicExpression SaveHistory(Language call, SymbolicExpression operation, Pairlist args, REnvironment environment); 65 | //function SaveHistory: TSymbolicExpression; 66 | //SymbolicExpression AddHistory(Language call, SymbolicExpression operation, Pairlist args, REnvironment environment); 67 | //function AddHistory: TSymbolicExpression; 68 | // -- End Unix-only 69 | end; 70 | 71 | implementation 72 | 73 | 74 | { TConsoleDevice } 75 | 76 | //------------------------------------------------------------------------------ 77 | function TConsoleDevice.Ask(question: string): TYesNoCancel; 78 | var 79 | input: string; 80 | trs: string; 81 | begin 82 | Writeln(Format('%s, y/n/c', [question])); 83 | ReadLn(input); 84 | trs := LowerCase(Trim(input)); 85 | if (trs = '') or (Length(trs) > 1) then 86 | result := TYesNoCancel.Cancel 87 | else 88 | begin 89 | if trs = 'y' then 90 | result := TYesNoCancel.Yes 91 | else if trs = 'n' then 92 | result := TYesNoCancel.No 93 | else 94 | result := TYesNoCancel.Cancel; 95 | end; 96 | end; 97 | //------------------------------------------------------------------------------ 98 | procedure TConsoleDevice.Busy(which: TBusyType); 99 | begin 100 | // -- Do nothing. 101 | end; 102 | //------------------------------------------------------------------------------ 103 | procedure TConsoleDevice.Callback; 104 | begin 105 | // -- Do nothing. 106 | end; 107 | //------------------------------------------------------------------------------ 108 | function TConsoleDevice.ChooseFile(create: boolean): string; 109 | begin 110 | { TODO : TConsoleDevice.ChooseFile - Check for Linux/OSX. } 111 | end; 112 | //------------------------------------------------------------------------------ 113 | procedure TConsoleDevice.CleanUp(saveAction: TStartupSaveAction; 114 | status: integer; runLast: boolean); 115 | begin 116 | { TODO : TConsoleDevice.ChooseFile - Check for Linux/OSX. } 117 | end; 118 | //------------------------------------------------------------------------------ 119 | procedure TConsoleDevice.ClearErrorConsole; 120 | begin 121 | { TODO : TConsoleDevice.ClearErrorConsole - Check for Linux/OSX. } 122 | end; 123 | //------------------------------------------------------------------------------ 124 | procedure TConsoleDevice.EditFile(fileName: string); 125 | begin 126 | // -- Do nothing. 127 | end; 128 | //------------------------------------------------------------------------------ 129 | procedure TConsoleDevice.FlushConsole; 130 | begin 131 | { TODO : TConsoleDevice.FlushConsole - Check for Linux/OSX. } 132 | end; 133 | //------------------------------------------------------------------------------ 134 | function TConsoleDevice.ReadConsole(prompt: string; capacity: integer; 135 | history: boolean): string; 136 | var 137 | rtn: string; 138 | begin 139 | WriteLn(prompt); 140 | ReadLn(rtn); 141 | result := rtn; 142 | end; 143 | //------------------------------------------------------------------------------ 144 | procedure TConsoleDevice.ResetConsole; 145 | begin 146 | { TODO : TConsoleDevice.ResetConsole - Check for Linux/OSX. } 147 | end; 148 | //------------------------------------------------------------------------------ 149 | function TConsoleDevice.ShowFiles(files, headers: TArray; title: string; 150 | delete: boolean; pager: string): boolean; 151 | begin 152 | { TODO : TConsoleDevice.ShowFiles - Check for Linux/OSX. } 153 | end; 154 | //------------------------------------------------------------------------------ 155 | procedure TConsoleDevice.ShowMessage(msg: string); 156 | begin 157 | WriteLn(msg); 158 | end; 159 | //------------------------------------------------------------------------------ 160 | procedure TConsoleDevice.Suicide(msg: string); 161 | begin 162 | if (TOSVersion.Platform = pfLinux) or (TOSVersion.Platform = pfMacOS) then 163 | begin 164 | WriteLn(msg); 165 | Halt; { TODO : Suicide error code? } 166 | end; 167 | end; 168 | //------------------------------------------------------------------------------ 169 | procedure TConsoleDevice.WriteConsole(output: string; length: integer; 170 | outputType: TConsoleOutputType); 171 | begin 172 | //OutputDebugString(PWideChar(output)); // -- Use this to write to the IDE event window. 173 | Writeln(output); 174 | end; 175 | 176 | end. 177 | -------------------------------------------------------------------------------- /Src/opaR.S4Object.pas: -------------------------------------------------------------------------------- 1 | unit opaR.S4Object; 2 | 3 | interface 4 | 5 | {------------------------------------------------------------------------------- 6 | 7 | opaR: object pascal for R 8 | 9 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 10 | 11 | Originator: Robert L S Devine 12 | 13 | Unless you have received this program directly from Sigma Sciences Ltd under 14 | the terms of a commercial license agreement, then this program is licensed 15 | to you under the terms of version 3 of the GNU Affero General Public License. 16 | Please refer to the AGPL licence document at: 17 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 18 | 19 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 20 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 21 | 22 | -------------------------------------------------------------------------------} 23 | 24 | uses 25 | Spring.Collections, 26 | 27 | opaR.SEXPREC, 28 | opaR.Utils, 29 | opaR.SymbolicExpression, 30 | opaR.Interfaces, 31 | opaR.DLLFunctions; 32 | 33 | type 34 | TS4Object = class(TSymbolicExpression, IS4Object) 35 | private 36 | FSlotNames: TArray; 37 | FdotSlotNamesFunc: IRFunction; 38 | function GetValueByName(name: string): ISymbolicExpression; 39 | function GetSlotNames: TArray; 40 | function GetSlotCount: integer; 41 | function mkString(s: string): PSEXPREC; 42 | procedure CheckSlotName(name: string); 43 | procedure SetValueByName(name: string; value: ISymbolicExpression); 44 | public 45 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); 46 | function GetClassDefinition: IS4Object; 47 | function GetSlotTypes: IDictionary; 48 | function HasSlot(slotName: string): boolean; 49 | property SlotCount: integer read GetSlotCount; 50 | property SlotNames: TArray read GetSlotNames; 51 | property Values[name: string]: ISymbolicExpression read GetValueByName write SetValueByName; default; 52 | end; 53 | 54 | implementation 55 | 56 | uses 57 | opaR.EngineExtension, 58 | opaR.ProtectedPointer; 59 | 60 | { TS4Object } 61 | 62 | //------------------------------------------------------------------------------ 63 | procedure TS4Object.CheckSlotName(name: string); 64 | var 65 | ix: integer; 66 | s: string; 67 | begin 68 | ix := -1; 69 | for s in SlotNames do 70 | begin 71 | if s = name then 72 | begin 73 | ix := 1; 74 | break; 75 | end; 76 | end; 77 | 78 | if ix < 0 then 79 | raise EopaRException.CreateFmt('Invalid slot name %s', [name]); 80 | end; 81 | //------------------------------------------------------------------------------ 82 | constructor TS4Object.Create(const engine: IREngine; pExpr: PSEXPREC); 83 | var 84 | expr: ISymbolicExpression; 85 | begin 86 | if FdotSlotNamesFunc = nil then 87 | begin 88 | expr := TEngineExtension(engine).Evaluate('invisible(.slotNames)'); 89 | FdotSlotNamesFunc := (expr as TSymbolicExpression).AsFunction; 90 | end; 91 | 92 | inherited Create(engine, pExpr); 93 | end; 94 | //------------------------------------------------------------------------------ 95 | function TS4Object.GetClassDefinition: IS4Object; 96 | var 97 | classSymbol: ISymbolicExpression; 98 | className: string; 99 | Ptr: PSEXPREC; 100 | begin 101 | classSymbol := TEngineExtension(Engine).GetPredefinedSymbol('R_ClassSymbol'); 102 | className := self.GetAttribute(classSymbol).AsCharacter.First; 103 | 104 | Ptr := Engine.Rapi.GetClassDef(PAnsiChar(AnsiString(className))); 105 | 106 | result := TS4Object.Create(Engine, Ptr); 107 | end; 108 | //------------------------------------------------------------------------------ 109 | function TS4Object.GetSlotCount: integer; 110 | begin 111 | result := Length(SlotNames); 112 | end; 113 | //------------------------------------------------------------------------------ 114 | function TS4Object.GetSlotNames: TArray; 115 | var 116 | args: TArray; 117 | i: integer; 118 | begin 119 | if Length(FSlotNames) = 0 then 120 | begin 121 | SetLength(args, 1); 122 | args[0] := self; 123 | FSlotNames := FdotSlotNamesFunc.Invoke(args).AsCharacter.ToArray; 124 | end; 125 | 126 | SetLength(result, Length(FSlotNames)); 127 | for i := 0 to Length(FSlotNames) - 1 do 128 | result[i] := FSlotNames[i]; 129 | end; 130 | //------------------------------------------------------------------------------ 131 | function TS4Object.GetSlotTypes: IDictionary; 132 | var 133 | definition: IS4Object; 134 | slots: ISymbolicExpression; 135 | slotsVec: ICharacterVector; 136 | namesSymbol: ISymbolicExpression; 137 | namesVec: ICharacterVector; 138 | s: string; 139 | ix: integer; 140 | begin 141 | definition := GetClassDefinition; 142 | slots := definition['slots']; 143 | namesSymbol := TEngineExtension(Engine).GetPredefinedSymbol('R_NamesSymbol'); 144 | 145 | namesVec := slots.GetAttribute(namesSymbol).AsCharacter; 146 | slotsVec := slots.AsCharacter; 147 | 148 | if namesVec.VectorLength <> slotsVec.VectorLength then 149 | raise EopaRException.Create('Vector length mismatch in TS4Object.GetSlotTypes'); 150 | 151 | result := TCollections.CreateDictionary; 152 | ix := 0; 153 | for s in namesVec do 154 | begin 155 | result.Add(s, slotsVec[ix]); 156 | ix := ix + 1; 157 | end; 158 | end; 159 | //------------------------------------------------------------------------------ 160 | function TS4Object.GetValueByName(name: string): ISymbolicExpression; 161 | var 162 | PSlotValue: PSEXPREC; 163 | Ptr: PSEXPREC; 164 | pp: TProtectedPointer; 165 | begin 166 | CheckSlotName(name); 167 | 168 | pp := TProtectedPointer.Create(self); 169 | try 170 | Ptr := mkString(name); 171 | PSlotValue := Engine.Rapi.DoSlot(Handle, Ptr); 172 | result := TSymbolicExpression.Create(Engine, PSlotValue); 173 | finally 174 | pp.Free; 175 | end; 176 | end; 177 | //------------------------------------------------------------------------------ 178 | function TS4Object.HasSlot(slotName: string): boolean; 179 | var 180 | pp: TProtectedPointer; 181 | Ptr: PSEXPREC; 182 | begin 183 | pp := TProtectedPointer.Create(self); 184 | try 185 | Ptr := mkString(slotName); 186 | result := Engine.Rapi.HasSlot(Handle, Ptr); 187 | finally 188 | pp.Free; 189 | end; 190 | end; 191 | //------------------------------------------------------------------------------ 192 | function TS4Object.mkString(s: string): PSEXPREC; 193 | begin 194 | result := Engine.Rapi.MakeString(PAnsiChar(AnsiString(s))); 195 | end; 196 | //------------------------------------------------------------------------------ 197 | procedure TS4Object.SetValueByName(name: string; value: ISymbolicExpression); 198 | var 199 | pp: TProtectedPointer; 200 | Ptr: PSEXPREC; 201 | begin 202 | CheckSlotName(name); 203 | 204 | pp := TProtectedPointer.Create(self); 205 | try 206 | Ptr := mkString(name); 207 | Engine.Rapi.DoSlotAssign(Handle, Ptr, value.Handle); 208 | finally 209 | pp.Free; 210 | end; 211 | end; 212 | 213 | end. 214 | -------------------------------------------------------------------------------- /Src/opaR.RFunction.pas: -------------------------------------------------------------------------------- 1 | unit opaR.RFunction; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | Requires: 25 | 26 | 1. Spring.Collections.Dictionaries from Spring4D.org 27 | 2. Generics.Tuples from https://github.com/malcolmgroves/generics.tuples 28 | 29 | -------------------------------------------------------------------------------} 30 | 31 | interface 32 | 33 | uses 34 | Spring.Collections.Dictionaries, 35 | Generics.Tuples, 36 | 37 | opaR.SEXPREC, 38 | opaR.DLLFunctions, 39 | opaR.Interfaces, 40 | opaR.SymbolicExpression, 41 | opaR.ProtectedPointer; 42 | 43 | type 44 | TRFunction = class abstract (TSymbolicExpression, IRFunction) 45 | private 46 | function EvaluateCall(p: PSEXPREC): PSEXPREC; 47 | function InvokeNamedFast(args: TArray>): ISymbolicExpression; 48 | protected 49 | function CreateCallAndEvaluate(Ptr: PSEXPREC): ISymbolicExpression; 50 | function InvokeOrderedArguments(args: TArray): ISymbolicExpression; 51 | function InvokeViaPairlist(argNames: TArray; args: TArray): ISymbolicExpression; 52 | public 53 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); 54 | function Invoke: ISymbolicExpression; overload; virtual; abstract; 55 | function Invoke(arg: ISymbolicExpression): ISymbolicExpression; overload; virtual; abstract; 56 | function Invoke(args: TArray): ISymbolicExpression; overload; virtual; abstract; 57 | function Invoke(args: TDictionary): ISymbolicExpression; overload; virtual; abstract; 58 | function InvokeNamed(args: TArray>): ISymbolicExpression; 59 | function InvokeStrArgs(args: TArray): ISymbolicExpression; 60 | end; 61 | 62 | implementation 63 | 64 | uses 65 | opaR.CharacterVector, 66 | opaR.GenericVector, 67 | opaR.PairList, 68 | opaR.Exception, 69 | opaR.EngineExtension; 70 | 71 | { TRFunction } 72 | 73 | //------------------------------------------------------------------------------ 74 | constructor TRFunction.Create(const engine: IREngine; pExpr: PSEXPREC); 75 | begin 76 | inherited Create(engine, pExpr); 77 | end; 78 | //------------------------------------------------------------------------------ 79 | function TRFunction.CreateCallAndEvaluate(Ptr: PSEXPREC): ISymbolicExpression; 80 | var 81 | p: PSEXPREC; 82 | pp: TProtectedPointer; 83 | p2: PSEXPREC; 84 | begin 85 | // -- Rf_lcons creates an expression. 86 | // -- Ptr is a (PairList) pointer passed from InvokeOrderedArguments. 87 | p := Engine.Rapi.LCons(Handle, Ptr); 88 | 89 | pp := TProtectedPointer.Create(Engine, p); 90 | try 91 | p2 := EvaluateCall(p); 92 | result := TSymbolicExpression.Create(Engine, p2); 93 | finally 94 | pp.Free; 95 | end; 96 | end; 97 | //------------------------------------------------------------------------------ 98 | function TRFunction.EvaluateCall(p: PSEXPREC): PSEXPREC; 99 | var 100 | evalPtr: PSEXPREC; 101 | errorOccurred: LongBool; 102 | pp: TProtectedPointer; 103 | begin 104 | evalPtr := Engine.Rapi.TryEval(p, TEngineExtension(Engine).GlobalEnvironment.Handle, errorOccurred); 105 | 106 | if errorOccurred then 107 | raise EopaREvaluationException.Create(TEngineExtension(Engine).LastErrorMessage); 108 | 109 | pp := TProtectedPointer.Create(Engine, evalPtr); 110 | try 111 | result := evalPtr; 112 | finally 113 | pp.Free; 114 | end; 115 | end; 116 | //------------------------------------------------------------------------------ 117 | function TRFunction.InvokeNamed(args: TArray>): ISymbolicExpression; 118 | begin 119 | result := InvokeNamedFast(args); 120 | end; 121 | //------------------------------------------------------------------------------ 122 | function TRFunction.InvokeNamedFast( 123 | args: TArray>): ISymbolicExpression; 124 | var 125 | i: integer; 126 | argument: PSEXPREC; 127 | expr: ISymbolicExpression; 128 | name: string; 129 | begin 130 | argument := TEngineExtension(Engine).NilValue; 131 | 132 | for i := Length(args) - 1 downto 0 do 133 | begin 134 | expr := args[i].Value2; 135 | argument := Engine.Rapi.Cons(expr.Handle, argument); 136 | name := args[i].Value1; 137 | if name <> '' then 138 | Engine.Rapi.SetTag(argument, Engine.Rapi.Install(PAnsiChar(AnsiString(name)))); 139 | end; 140 | 141 | result := CreateCallAndEvaluate(argument); 142 | end; 143 | //------------------------------------------------------------------------------ 144 | function TRFunction.InvokeOrderedArguments( 145 | args: TArray): ISymbolicExpression; 146 | var 147 | i: integer; 148 | argument: PSEXPREC; 149 | begin 150 | // -- Rf_cons creates a PairList. 151 | argument := TEngineExtension(Engine).NilValue; 152 | for i := Length(args) - 1 downto 0 do 153 | argument := Engine.Rapi.Cons(args[i].Handle, argument); 154 | 155 | result := CreateCallAndEvaluate(argument); 156 | end; 157 | //------------------------------------------------------------------------------ 158 | function TRFunction.InvokeStrArgs(args: TArray): ISymbolicExpression; 159 | var 160 | i: integer; 161 | exprArray: TArray; 162 | begin 163 | SetLength(exprArray, Length(args)); 164 | for i := 0 to Length(args) - 1 do 165 | exprArray[i] := TEngineExtension(Engine).Evaluate(args[i]) as TSymbolicExpression; 166 | 167 | result := Invoke(exprArray); 168 | end; 169 | //------------------------------------------------------------------------------ 170 | function TRFunction.InvokeViaPairlist(argNames: TArray; 171 | args: TArray): ISymbolicExpression; 172 | var 173 | names: ICharacterVector; 174 | arguments: IGenericVector; 175 | pairList: IPairList; 176 | h: PSEXPREC; 177 | begin 178 | pairList := nil; 179 | names := TCharacterVector.Create(Engine, argNames); 180 | arguments := TGenericVector.Create(Engine, args); 181 | 182 | arguments.SetNames(names); 183 | pairList := arguments.ToPairlist; 184 | h := pairList.Handle; 185 | 186 | if h <> nil then 187 | result := CreateCallAndEvaluate(h) 188 | else 189 | result := nil; 190 | end; 191 | 192 | end. 193 | -------------------------------------------------------------------------------- /Src/opaR.NumericVector.pas: -------------------------------------------------------------------------------- 1 | unit opaR.NumericVector; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | {$IFDEF MSWINDOWS} 26 | Winapi.Windows, 27 | {$ENDIF} 28 | System.Types, 29 | 30 | Spring.Collections, 31 | 32 | opaR.Interfaces, 33 | opaR.SEXPREC, 34 | opaR.Utils, 35 | opaR.DLLFunctions, 36 | opaR.Vector, 37 | opaR.ProtectedPointer; 38 | 39 | 40 | type 41 | TNumericVector = class(TRVector, INumericVector) 42 | protected 43 | function GetDataSize: integer; override; 44 | function GetValue(ix: integer): double; override; 45 | procedure SetValue(ix: integer; value: double); override; 46 | public 47 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); overload; 48 | constructor Create(const engine: IREngine; vecLength: integer); overload; 49 | constructor Create(const engine: IREngine; const vector: IEnumerable); overload; 50 | constructor Create(const engine: IREngine; const vector: TArray); overload; 51 | function GetArrayFast: TArray; override; 52 | procedure CopyTo(const destination: TArray; copyCount: integer; sourceIndex: integer = 0; destinationIndex: integer = 0); //override; 53 | procedure SetVectorDirect(const values: TArray); override; 54 | end; 55 | 56 | 57 | implementation 58 | 59 | 60 | { TNumericVector } 61 | 62 | //------------------------------------------------------------------------------ 63 | constructor TNumericVector.Create(const engine: IREngine; vecLength: integer); 64 | begin 65 | // -- The base constructor calls Rf_allocVector 66 | inherited Create(engine, TSymbolicExpressionType.NumericVector, vecLength); 67 | end; 68 | //------------------------------------------------------------------------------ 69 | constructor TNumericVector.Create(const engine: IREngine; pExpr: PSEXPREC); 70 | begin 71 | // -- pExpr is a pointer to a numeric vector. 72 | inherited Create(engine, pExpr); 73 | end; 74 | //------------------------------------------------------------------------------ 75 | constructor TNumericVector.Create(const engine: IREngine; const vector: IEnumerable); 76 | begin 77 | // -- The base constructor calls SetVector(vector.ToArray), which in turn 78 | // -- calls SetVectorDirect (implemented in this class). 79 | inherited Create(engine, TSymbolicExpressionType.NumericVector, vector); 80 | end; 81 | //------------------------------------------------------------------------------ 82 | constructor TNumericVector.Create(const engine: IREngine; const vector: TArray); 83 | var 84 | pExpr: PSEXPREC; 85 | begin 86 | // -- There's no base constructor that uses a TArray parameter, so build 87 | // -- everything we need here. R.NET calls the base constructor that uses 88 | // -- the vector length, but this seems to create an extra array. ?? 89 | 90 | // -- First get the pointer to the R expression. 91 | pExpr := Engine.Rapi.AllocVector(TSymbolicExpressionType.NumericVector, Length(vector)); 92 | 93 | Create(engine, pExpr); 94 | 95 | // -- Now copy the array data. 96 | CopyMemory(DataPointer, PDouble(vector), Length(vector) * DataSize); 97 | end; 98 | //------------------------------------------------------------------------------ 99 | function TNumericVector.GetArrayFast: TArray; 100 | begin 101 | SetLength(result, self.VectorLength); 102 | CopyMemory(PDouble(result), DataPointer, self.VectorLength * DataSize); 103 | end; 104 | //------------------------------------------------------------------------------ 105 | function TNumericVector.GetDataSize: integer; 106 | begin 107 | result := SizeOf(double); 108 | end; 109 | //------------------------------------------------------------------------------ 110 | function TNumericVector.GetValue(ix: integer): double; 111 | var 112 | pp: TProtectedPointer; 113 | PData: PDouble; 114 | offset: integer; 115 | begin 116 | if (ix < 0) or (ix >= VectorLength) then 117 | raise EopaRException.Create('Error: Vector index out of bounds'); 118 | 119 | pp := TProtectedPointer.Create(self); 120 | try 121 | offset := GetOffset(ix); 122 | PData := PDouble(NativeInt(DataPointer) + offset); 123 | result := PData^; 124 | finally 125 | pp.Free; 126 | end; 127 | end; 128 | //------------------------------------------------------------------------------ 129 | procedure TNumericVector.SetValue(ix: integer; value: double); 130 | var 131 | pp: TProtectedPointer; 132 | PData: PDouble; 133 | offset: integer; 134 | begin 135 | if (ix < 0) or (ix >= VectorLength) then 136 | raise EopaRException.Create('Error: Vector index out of bounds'); 137 | 138 | pp := TProtectedPointer.Create(self); 139 | try 140 | offset := GetOffset(ix); 141 | PData := PDouble(NativeInt(DataPointer) + offset); 142 | PData^ := value; 143 | finally 144 | pp.Free; 145 | end; 146 | end; 147 | //------------------------------------------------------------------------------ 148 | procedure TNumericVector.SetVectorDirect(const values: TArray); 149 | begin 150 | // -- Delphi, .NET and R all use contiguous memory blocks for 1D arrays. 151 | CopyMemory(DataPointer, PDouble(values), Length(values) * DataSize); 152 | end; 153 | //------------------------------------------------------------------------------ 154 | procedure TNumericVector.CopyTo(const destination: TArray; copyCount, 155 | sourceIndex, destinationIndex: integer); 156 | var 157 | offset: integer; 158 | PData: PDouble; 159 | PDestination: PDouble; 160 | begin 161 | if Length(destination) = 0 then 162 | raise EopaRException.Create('Error: Destination array cannot be nil'); 163 | 164 | if (copyCount <= 0) then 165 | raise EopaRException.Create('Error: Number of elements to copy must be > 0'); 166 | 167 | if (sourceIndex < 0) or (VectorLength < sourceIndex + copyCount) then 168 | raise EopaRException.Create('Error: Source array index out of bounds'); 169 | 170 | if (destinationIndex < 0) or (Length(destination) < destinationIndex + copyCount) then 171 | raise EopaRException.Create('Error: Destination array index out of bounds'); 172 | 173 | offset := GetOffset(sourceIndex); 174 | PData := PDouble(NativeInt(DataPointer) + offset); 175 | PDestination := PDouble(NativeInt(PDouble(destination)) + destinationIndex * SizeOf(double)); 176 | CopyMemory(PDestination, PData, copyCount * DataSize); 177 | end; 178 | 179 | end. 180 | 181 | 182 | 183 | 184 | 185 | -------------------------------------------------------------------------------- /Src/Devices/opaR.Devices.CharacterDeviceAdapter.pas: -------------------------------------------------------------------------------- 1 | unit opaR.Devices.CharacterDeviceAdapter; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | { TODO : TCharacterDeviceAdapter - Unix functions. } 23 | 24 | interface 25 | 26 | uses 27 | WinApi.Windows, 28 | System.SysUtils, 29 | System.AnsiStrings, 30 | System.Classes, 31 | 32 | opaR.StartupParameter, 33 | opaR.DLLFunctions, 34 | opaR.Utils, 35 | opaR.Interfaces; 36 | 37 | type 38 | TCharacterDeviceAdapter = class 39 | private 40 | class var FLastDevice: ICharacterDevice; 41 | FDevice: ICharacterDevice; 42 | FDLLHandle: HMODULE; 43 | class function ToNativeUnixPath(path: AnsiString): AnsiString; 44 | class function GetDevice: ICharacterDevice; static; 45 | public 46 | constructor Create(device: ICharacterDevice); 47 | procedure Install(engine: IREngine; parameter: TStartupParameter); 48 | procedure SetupWindowsDevice(parameter: TStartupParameter); 49 | class property Device: ICharacterDevice read GetDevice; 50 | end; 51 | 52 | function ReadConsole(prompt, buffer: PAnsiChar; count: integer; history: LongBool): LongBool; cdecl; 53 | procedure WriteConsole(const buffer: PAnsiChar; length: integer); cdecl; 54 | procedure WriteConsoleEx(const buffer: PAnsiChar; length: integer; outputType: TConsoleOutputType); cdecl; 55 | procedure Callback; cdecl; 56 | procedure ShowMessage(const msg: PAnsiChar); cdecl; 57 | function Ask(const question: PAnsiChar): TYesNoCancel; cdecl; 58 | procedure Busy(which: TBusyType); cdecl; 59 | 60 | 61 | implementation 62 | 63 | //------------------------------------------------------------------------------ 64 | function ReadConsole(prompt, buffer: PAnsiChar; count: integer; history: LongBool): LongBool; cdecl; 65 | var 66 | input: string; 67 | begin 68 | result := false; 69 | if assigned(TCharacterDeviceAdapter.Device) then 70 | begin 71 | input := TCharacterDeviceAdapter.Device.ReadConsole(string(prompt), count, history); 72 | result := input <> ''; 73 | input := input + #10; 74 | buffer := PAnsiChar(AnsiString(input)); 75 | end; 76 | end; 77 | //------------------------------------------------------------------------------ 78 | procedure WriteConsole(const buffer: PAnsiChar; length: integer); cdecl; 79 | begin 80 | WriteConsoleEx(buffer, length, TConsoleOutputType.None_); 81 | end; 82 | //------------------------------------------------------------------------------ 83 | procedure WriteConsoleEx(const buffer: PAnsiChar; length: integer; outputType: TConsoleOutputType); cdecl; 84 | begin 85 | //OutputDebugString(PWideChar(string(buffer))); 86 | if assigned(TCharacterDeviceAdapter.Device) then 87 | TCharacterDeviceAdapter.Device.WriteConsole(string(buffer), length, TConsoleOutputType.None_); 88 | end; 89 | //------------------------------------------------------------------------------ 90 | procedure Callback; cdecl; 91 | begin 92 | if assigned(TCharacterDeviceAdapter.Device) then 93 | TCharacterDeviceAdapter.Device.Callback; 94 | end; 95 | //------------------------------------------------------------------------------ 96 | procedure ShowMessage(const msg: PAnsiChar); cdecl; 97 | begin 98 | if assigned(TCharacterDeviceAdapter.Device) then 99 | TCharacterDeviceAdapter.Device.ShowMessage(string(msg)); 100 | end; 101 | //------------------------------------------------------------------------------ 102 | function Ask(const question: PAnsiChar): TYesNoCancel; cdecl; 103 | begin 104 | if assigned(TCharacterDeviceAdapter.Device) then 105 | result := TCharacterDeviceAdapter.Device.Ask(string(question)) 106 | else 107 | result := TYesNoCancel.Cancel; 108 | end; 109 | //------------------------------------------------------------------------------ 110 | procedure Busy(which: TBusyType); cdecl; 111 | begin 112 | if assigned(TCharacterDeviceAdapter.Device) then 113 | TCharacterDeviceAdapter.Device.Busy(which); 114 | end; 115 | 116 | 117 | 118 | { TCharacterDeviceAdapter } 119 | 120 | //------------------------------------------------------------------------------ 121 | constructor TCharacterDeviceAdapter.Create(device: ICharacterDevice); 122 | begin 123 | if device <> nil then 124 | begin 125 | FLastDevice := device; 126 | FDevice := device; 127 | end 128 | else 129 | raise EopaRException.Create('Nil device in TCharacterDeviceAdapter constructor'); 130 | end; 131 | //------------------------------------------------------------------------------ 132 | class function TCharacterDeviceAdapter.GetDevice: ICharacterDevice; 133 | begin 134 | if FDevice = nil then 135 | result := FLastDevice 136 | else 137 | result := FDevice; 138 | end; 139 | //------------------------------------------------------------------------------ 140 | procedure TCharacterDeviceAdapter.Install(engine: IREngine; parameter: TStartupParameter); 141 | begin 142 | FDLLHandle := engine.Handle; 143 | case TOSVersion.Platform of 144 | pfWindows: begin 145 | SetupWindowsDevice(parameter); 146 | end; 147 | 148 | pfMacOS, pfLinux: begin 149 | { TODO : TCharacterDeviceAdapter.Install - pfMacOS/pfLinux } 150 | end 151 | else 152 | raise EopaRException.Create('Error: Platform not supported'); 153 | end; 154 | end; 155 | //------------------------------------------------------------------------------ 156 | procedure TCharacterDeviceAdapter.SetupWindowsDevice( 157 | parameter: TStartupParameter); 158 | var 159 | getRUser: TRFnGetRUser; 160 | home: AnsiString; 161 | begin 162 | if parameter.RHome = '' then 163 | parameter.RHome := ToNativeUnixPath(AnsiString(GetEnvironmentVariable('R_HOME'))); 164 | 165 | if parameter.Home = '' then 166 | begin 167 | getRUser := GetProcAddress(FDLLHandle, 'getRUser'); 168 | home := getRUser; 169 | parameter.Home := ToNativeUnixPath(home); 170 | end; 171 | 172 | parameter.Start.ReadConsole := ReadConsole; 173 | parameter.Start.WriteConsole := WriteConsole; 174 | parameter.Start.WriteConsoleEx := WriteConsoleEx; 175 | parameter.Start.CallBack := Callback; 176 | parameter.Start.ShowMessage := ShowMessage; 177 | parameter.Start.YesNoCancel := Ask; 178 | parameter.Start.Busy := Busy; 179 | end; 180 | //------------------------------------------------------------------------------ 181 | class function TCharacterDeviceAdapter.ToNativeUnixPath( 182 | path: AnsiString): AnsiString; 183 | begin 184 | result := AnsiReplaceStr(path, '\', '/'); 185 | end; 186 | 187 | 188 | 189 | end. 190 | -------------------------------------------------------------------------------- /Tests/FactorTests.pas: -------------------------------------------------------------------------------- 1 | unit FactorTests; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | TestFramework, 8 | 9 | opaR.TestUtils, 10 | 11 | opaR.Engine, 12 | opaR.SymbolicExpression, 13 | opaR.Interfaces, 14 | opaR.Factor; 15 | 16 | type 17 | // -- Remember that we require a non-initalised enum. 18 | TGroup = (Treatment, Control); 19 | 20 | TFactorTests = class(TTestCase) 21 | private 22 | FEngine: IREngine; 23 | protected 24 | procedure SetUp; override; 25 | procedure TearDown; override; 26 | published 27 | procedure AsCharacterFactors_Test; 28 | procedure GetFactorsEnum_Test; 29 | procedure GetLevels_Test; 30 | procedure IsOrderedFalse_Test; 31 | procedure IsOrderedTrue_Test; 32 | procedure Length_Test; 33 | procedure MissingValues_Test; 34 | end; 35 | 36 | 37 | implementation 38 | 39 | { TFactorTests } 40 | 41 | //------------------------------------------------------------------------------ 42 | procedure TFactorTests.AsCharacterFactors_Test; 43 | var 44 | charVec: ICharacterVector; 45 | begin 46 | charVec := FEngine.Evaluate('as.factor(rep(letters[1:3], 5))').AsCharacter; 47 | CheckEquals(15, charVec.VectorLength); 48 | CheckEquals('a', charVec[0]); 49 | CheckEquals('b', charVec[1]); 50 | CheckEquals('c', charVec[2]); 51 | CheckEquals('a', charVec[0]); 52 | end; 53 | //------------------------------------------------------------------------------ 54 | procedure TFactorTests.GetFactorsEnum_Test; 55 | var 56 | code: string; 57 | t: string; 58 | c: string; 59 | factor: IFactor; 60 | expected: TArray; 61 | factors: TArray; 62 | i: integer; 63 | arraysEqual: boolean; 64 | begin 65 | t := QuotedStr('T'); 66 | c := QuotedStr('C'); 67 | code := 'factor(c(rep(' + t + ', 3), rep(' + c + ', 5), rep(' + t + ', 4), rep(' + c + ', 2)), levels=c(' + t + ', ' + c + '), labels=c(' + QuotedStr('Treatment') + ', ' + QuotedStr('Control') + '))'; 68 | factor := FEngine.Evaluate(code).AsFactor; 69 | factors := (factor as TFactor).GetFactors; 70 | expected := TArray.Create(Treatment, Treatment, Treatment, 71 | Control, Control, Control, Control, Control, 72 | Treatment, Treatment, Treatment, Treatment, 73 | Control, Control); 74 | 75 | CheckEquals(14, Length(factors)); 76 | CheckEquals(14, Length(expected)); 77 | 78 | if Length(factors) = Length(expected) then 79 | begin 80 | arraysEqual := true; 81 | for i := 0 to Length(factors) - 1 do 82 | begin 83 | if factors[i] <> expected[i] then 84 | begin 85 | arraysEqual := false; 86 | break; 87 | end; 88 | end; 89 | CheckEquals(true, arraysEqual); 90 | end; 91 | end; 92 | //------------------------------------------------------------------------------ 93 | procedure TFactorTests.GetLevels_Test; 94 | var 95 | fac: IFactor; 96 | levelA: string; 97 | levelB: string; 98 | levelC: string; 99 | levels: TArray; 100 | expected: TArray; 101 | begin 102 | levelA := QuotedStr('A'); 103 | levelB := QuotedStr('B'); 104 | levelC := QuotedStr('C'); 105 | 106 | fac := FEngine.Evaluate('fac <- factor(c(' + levelA + ',' + levelB + ',' + levelA + ',' 107 | + levelC + ',' + levelB + '))').AsFactor; 108 | levels := fac.GetLevels; 109 | expected := TArray.Create('A', 'B', 'C'); 110 | CheckEquals(true, TopaRArrayUtils.StringArraysEqual(expected, levels)); 111 | 112 | levelA := QuotedStr('1st'); 113 | levelB := QuotedStr('2nd'); 114 | levelC := QuotedStr('3rd'); 115 | // -- Note the #10 (CR) in the code string. 116 | fac := FEngine.Evaluate('levels(fac) <- c(' + levelA + ', ' + levelB + ', ' + levelC + ')' + #10 + 'fac').AsFactor; 117 | levels := fac.GetLevels; 118 | expected := TArray.Create('1st', '2nd', '3rd'); 119 | CheckEquals(true, TopaRArrayUtils.StringArraysEqual(expected, levels)); 120 | end; 121 | //------------------------------------------------------------------------------ 122 | procedure TFactorTests.IsOrderedFalse_Test; 123 | var 124 | fac: IFactor; 125 | levelA: string; 126 | levelB: string; 127 | levelC: string; 128 | begin 129 | levelA := QuotedStr('A'); 130 | levelB := QuotedStr('B'); 131 | levelC := QuotedStr('C'); 132 | 133 | fac := FEngine.Evaluate('factor(c(' + levelA + ',' + levelB + ',' + levelA + ',' 134 | + levelC + ',' + levelB + '), ordered=FALSE)').AsFactor; 135 | CheckEquals(false, fac.IsOrdered); 136 | end; 137 | //------------------------------------------------------------------------------ 138 | procedure TFactorTests.IsOrderedTrue_Test; 139 | var 140 | fac: IFactor; 141 | levelA: string; 142 | levelB: string; 143 | levelC: string; 144 | begin 145 | levelA := QuotedStr('A'); 146 | levelB := QuotedStr('B'); 147 | levelC := QuotedStr('C'); 148 | 149 | fac := FEngine.Evaluate('factor(c(' + levelA + ',' + levelB + ',' + levelA + ',' 150 | + levelC + ',' + levelB + '), ordered=TRUE)').AsFactor; 151 | CheckEquals(true, fac.IsOrdered); 152 | end; 153 | //------------------------------------------------------------------------------ 154 | procedure TFactorTests.Length_Test; 155 | var 156 | fac: IFactor; 157 | levelA: string; 158 | levelB: string; 159 | levelC: string; 160 | begin 161 | levelA := QuotedStr('A'); 162 | levelB := QuotedStr('B'); 163 | levelC := QuotedStr('C'); 164 | 165 | fac := FEngine.Evaluate('factor(c(' + levelA + ',' + levelB + ',' + levelA + ',' 166 | + levelC + ',' + levelB + '))').AsFactor; 167 | CheckEquals(5, fac.VectorLength); 168 | end; 169 | //------------------------------------------------------------------------------ 170 | procedure TFactorTests.MissingValues_Test; 171 | var 172 | fac1: IFactor; 173 | levelA: string; 174 | levelB: string; 175 | levelC: string; 176 | factors: TArray; 177 | expected: TArray; 178 | begin 179 | levelA := QuotedStr('A'); 180 | levelB := QuotedStr('B'); 181 | levelC := QuotedStr('C'); 182 | 183 | fac1 := FEngine.Evaluate('fac1 <- factor(c(' + levelA + ',' + levelB + ',' + levelA + ', NA,' 184 | + levelC + ',' + levelB + '), ordered=TRUE)').AsFactor; 185 | expected := TArray.Create('A', 'B', 'A', '', 'C', 'B'); 186 | factors := fac1.GetFactors; 187 | CheckEquals(true, TopaRArrayUtils.StringArraysEqual(expected, factors)); 188 | 189 | levelA := QuotedStr('1st'); 190 | levelB := QuotedStr('2nd'); 191 | levelC := QuotedStr('3rd'); 192 | // -- Note the #10 (CR) in the code string. 193 | fac1 := FEngine.Evaluate('levels(fac1) <- c(' + levelA + ', ' + levelB + ', ' + levelC + ')' + #10 + 'fac1').AsFactor; 194 | expected := TArray.Create('1st', '2nd', '1st', '', '3rd', '2nd'); 195 | factors := fac1.GetFactors; 196 | CheckEquals(true, TopaRArrayUtils.StringArraysEqual(expected, factors)); 197 | end; 198 | //------------------------------------------------------------------------------ 199 | procedure TFactorTests.SetUp; 200 | begin 201 | TREngine.SetEnvironmentVariables; 202 | FEngine := TREngine.GetInstance; 203 | end; 204 | //------------------------------------------------------------------------------ 205 | procedure TFactorTests.TearDown; 206 | begin 207 | inherited; 208 | 209 | end; 210 | 211 | 212 | initialization 213 | TestFramework.RegisterTest(TFactorTests.Suite); 214 | 215 | end. 216 | -------------------------------------------------------------------------------- /Src/opaR.IntegerVector.pas: -------------------------------------------------------------------------------- 1 | unit opaR.IntegerVector; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | interface 23 | 24 | uses 25 | {$IFDEF MSWINDOWS} 26 | Winapi.Windows, 27 | {$ENDIF} 28 | System.Types, 29 | 30 | Spring.Collections, 31 | 32 | opaR.Interfaces, 33 | opaR.SEXPREC, 34 | opaR.Utils, 35 | opaR.DLLFunctions, 36 | opaR.Vector, 37 | opaR.ProtectedPointer; 38 | 39 | type 40 | TIntegerVector = class(TRVector, IIntegerVector) 41 | protected 42 | function GetDataSize: integer; override; 43 | function GetValue(ix: integer): integer; override; 44 | procedure SetValue(ix: integer; value: integer); override; 45 | function GetNACode: integer; 46 | public 47 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); overload; 48 | constructor Create(const engine: IREngine; vecLength: integer); overload; 49 | constructor Create(const engine: IREngine; const vector: IEnumerable); overload; 50 | constructor Create(const engine: IREngine; const vector: TArray); overload; 51 | function GetArrayFast: TArray; override; 52 | procedure CopyTo(const destination: TArray; copyCount: integer; sourceIndex: integer = 0; destinationIndex: integer = 0); //override; 53 | procedure SetVectorDirect(const values: TArray); override; 54 | property NACode: integer read GetNACode; 55 | end; 56 | 57 | implementation 58 | 59 | { TIntegerVector } 60 | 61 | //------------------------------------------------------------------------------ 62 | procedure TIntegerVector.CopyTo(const destination: TArray; copyCount, 63 | sourceIndex, destinationIndex: integer); 64 | var 65 | offset: integer; 66 | PData: PInteger; 67 | PDestination: PInteger; 68 | begin 69 | if destination = nil then 70 | raise EopaRException.Create('Error: Destination array cannot be nil'); 71 | 72 | if (copyCount <= 0) then 73 | raise EopaRException.Create('Error: Number of elements to copy must be > 0'); 74 | 75 | if (sourceIndex < 0) or (VectorLength < sourceIndex + copyCount) then 76 | raise EopaRException.Create('Error: Source array index out of bounds'); 77 | 78 | if (destinationIndex < 0) or (Length(destination) < destinationIndex + copyCount) then 79 | raise EopaRException.Create('Error: Destination array index out of bounds'); 80 | 81 | offset := GetOffset(sourceIndex); 82 | PData := PInteger(NativeInt(DataPointer) + offset); 83 | PDestination := PInteger(NativeInt(PInteger(destination)) + destinationIndex * SizeOf(integer)); 84 | CopyMemory(PDestination, PData, copyCount * DataSize); 85 | end; 86 | //------------------------------------------------------------------------------ 87 | constructor TIntegerVector.Create(const engine: IREngine; pExpr: PSEXPREC); 88 | begin 89 | // -- pExpr is a pointer to an integer vector. 90 | inherited Create(engine, pExpr); 91 | end; 92 | //------------------------------------------------------------------------------ 93 | constructor TIntegerVector.Create(const engine: IREngine; vecLength: integer); 94 | begin 95 | // -- The base constructor calls Rf_allocVector 96 | inherited Create(engine, TSymbolicExpressionType.IntegerVector, vecLength); 97 | end; 98 | //------------------------------------------------------------------------------ 99 | constructor TIntegerVector.Create(const engine: IREngine; const vector: TArray); 100 | var 101 | pExpr: PSEXPREC; 102 | begin 103 | // -- There's no base constructor that uses a TArray parameter, so build 104 | // -- everything we need here. 105 | 106 | // -- First get the pointer to the R expression. 107 | pExpr := Engine.Rapi.AllocVector(TSymbolicExpressionType.IntegerVector, Length(vector)); 108 | 109 | Create(engine, pExpr); 110 | 111 | // -- Now copy the array data. 112 | CopyMemory(DataPointer, PInteger(vector), Length(vector) * DataSize); 113 | end; 114 | //------------------------------------------------------------------------------ 115 | constructor TIntegerVector.Create(const engine: IREngine; 116 | const vector: IEnumerable); 117 | begin 118 | // -- The base constructor calls SetVector(vector.ToArray), which in turn 119 | // -- calls SetVectorDirect (implemented in this class). 120 | inherited Create(engine, TSymbolicExpressionType.IntegerVector, vector); 121 | end; 122 | //------------------------------------------------------------------------------ 123 | function TIntegerVector.GetArrayFast: TArray; 124 | begin 125 | SetLength(result, self.VectorLength); 126 | CopyMemory(PInteger(result), DataPointer, self.VectorLength * DataSize); 127 | end; 128 | //------------------------------------------------------------------------------ 129 | function TIntegerVector.GetDataSize: integer; 130 | begin 131 | result := SizeOf(integer); // -- Note that SizeOf(integer) = 4 on Win32 and x64 132 | end; 133 | //------------------------------------------------------------------------------ 134 | function TIntegerVector.GetNACode: integer; 135 | begin 136 | // -- In .NET int.MinValue = -2147483648, in Delphi and .NET MaxInt = 2147483647. 137 | result := -1 * MaxInt - 1; 138 | end; 139 | //------------------------------------------------------------------------------ 140 | function TIntegerVector.GetValue(ix: integer): integer; 141 | var 142 | pp: TProtectedPointer; 143 | PData: PInteger; 144 | offset: integer; 145 | begin 146 | if (ix < 0) or (ix >= VectorLength) then 147 | raise EopaRException.Create('Error: Vector index out of bounds'); 148 | 149 | pp := TProtectedPointer.Create(self); 150 | try 151 | offset := GetOffset(ix); 152 | PData := PInteger(NativeInt(DataPointer) + offset); 153 | result := PData^; 154 | finally 155 | pp.Free; 156 | end; 157 | end; 158 | //------------------------------------------------------------------------------ 159 | procedure TIntegerVector.SetValue(ix, value: integer); 160 | var 161 | pp: TProtectedPointer; 162 | PData: PInteger; 163 | offset: integer; 164 | begin 165 | if (ix < 0) or (ix >= VectorLength) then 166 | raise EopaRException.Create('Error: Vector index out of bounds'); 167 | 168 | pp := TProtectedPointer.Create(self); 169 | try 170 | offset := GetOffset(ix); 171 | PData := PInteger(NativeInt(DataPointer) + offset); 172 | PData^ := value; 173 | finally 174 | pp.Free; 175 | end; 176 | end; 177 | //------------------------------------------------------------------------------ 178 | procedure TIntegerVector.SetVectorDirect(const values: TArray); 179 | begin 180 | // -- Delphi, .NET and R all use contiguous memory blocks for 1D arrays. 181 | CopyMemory(DataPointer, PInteger(values), Length(values) * DataSize); 182 | end; 183 | 184 | end. 185 | 186 | 187 | 188 | -------------------------------------------------------------------------------- /Src/opaR.GenericVector.pas: -------------------------------------------------------------------------------- 1 | unit opaR.GenericVector; 2 | 3 | {------------------------------------------------------------------------------- 4 | 5 | opaR: object pascal for R 6 | 7 | Copyright (C) 2015-2016 Sigma Sciences Ltd. 8 | 9 | Originator: Robert L S Devine 10 | 11 | Unless you have received this program directly from Sigma Sciences Ltd under 12 | the terms of a commercial license agreement, then this program is licensed 13 | to you under the terms of version 3 of the GNU Affero General Public License. 14 | Please refer to the AGPL licence document at: 15 | http://www.gnu.org/licenses/agpl-3.0.txt for more details. 16 | 17 | This program is distributed WITHOUT ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING 18 | THOSE OF NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | -------------------------------------------------------------------------------} 21 | 22 | {------------------------------------------------------------------------------- 23 | 24 | TGenericVector wraps the R list type. Note that this is not the same as a PairList. 25 | 26 | -------------------------------------------------------------------------------} 27 | 28 | interface 29 | 30 | uses 31 | Spring.Collections, 32 | 33 | opaR.SEXPREC, 34 | opaR.VECTOR_SEXPREC, 35 | opaR.Utils, 36 | opaR.DLLFunctions, 37 | opaR.Vector, 38 | opaR.Interfaces, 39 | opaR.ProtectedPointer, 40 | opaR.SymbolicExpression, 41 | opaR.PairList, 42 | opaR.CharacterVector; 43 | 44 | type 45 | TGenericVector = class(TRVector, IGenericVector) 46 | protected 47 | function GetDataSize: integer; override; 48 | function GetValue(ix: integer): ISymbolicExpression; override; 49 | procedure SetValue(ix: integer; value: ISymbolicExpression); override; 50 | public 51 | constructor Create(const engine: IREngine; pExpr: PSEXPREC); overload; 52 | constructor Create(const engine: IREngine; vecLength: integer); overload; 53 | constructor Create(const engine: IREngine; const vector: IEnumerable); overload; 54 | constructor Create(const engine: IREngine; const vector: TArray); overload; 55 | function GetArrayFast: TArray; override; 56 | function ToPairlist: IPairlist; 57 | procedure SetNames(const names: TArray); overload; 58 | procedure SetNames(const names: ICharacterVector); overload; 59 | procedure SetVectorDirect(const values: TArray); override; 60 | end; 61 | 62 | implementation 63 | 64 | uses 65 | opaR.EngineExtension; 66 | 67 | { TGenericVector } 68 | 69 | //------------------------------------------------------------------------------ 70 | constructor TGenericVector.Create(const engine: IREngine; vecLength: integer); 71 | begin 72 | inherited Create(engine, TSymbolicExpressionType.ExpressionVector, vecLength); 73 | end; 74 | //------------------------------------------------------------------------------ 75 | constructor TGenericVector.Create(const engine: IREngine; pExpr: PSEXPREC); 76 | begin 77 | inherited Create(engine, pExpr); 78 | end; 79 | //------------------------------------------------------------------------------ 80 | constructor TGenericVector.Create(const engine: IREngine; 81 | const vector: IEnumerable); 82 | var 83 | ix: integer; 84 | val: TSymbolicExpression; 85 | len: integer; 86 | pExpr: PSEXPREC; 87 | begin 88 | // -- First get the pointer to the R expression. 89 | len := vector.Count; 90 | pExpr := Engine.Rapi.AllocVector(TSymbolicExpressionType.ExpressionVector, len); 91 | 92 | // -- Call the base TSymbolicExpression constructor. 93 | Create(engine, pExpr); 94 | 95 | ix := 0; 96 | for val in vector do 97 | begin 98 | SetValue(ix, val); 99 | Inc(ix); 100 | end; 101 | end; 102 | //------------------------------------------------------------------------------ 103 | constructor TGenericVector.Create(const engine: IREngine; 104 | const vector: TArray); 105 | var 106 | ix: integer; 107 | len: integer; 108 | pExpr: PSEXPREC; 109 | begin 110 | // -- First get the pointer to the R expression. 111 | len := Length(vector); 112 | pExpr := Engine.Rapi.AllocVector(TSymbolicExpressionType.ExpressionVector, len); 113 | 114 | // -- Call the base TSymbolicExpression constructor. 115 | Create(engine, pExpr); 116 | 117 | // -- Now copy the array data. 118 | for ix := 0 to len - 1 do 119 | SetValue(ix, vector[ix]); 120 | end; 121 | //------------------------------------------------------------------------------ 122 | function TGenericVector.GetArrayFast: TArray; 123 | var 124 | i: integer; 125 | begin 126 | SetLength(result, VectorLength); 127 | for i := 0 to VectorLength - 1 do 128 | result[i] := GetValue(i); 129 | end; 130 | //------------------------------------------------------------------------------ 131 | function TGenericVector.GetDataSize: integer; 132 | begin 133 | result := SizeOf(PSEXPREC); 134 | end; 135 | //------------------------------------------------------------------------------ 136 | function TGenericVector.GetValue(ix: integer): ISymbolicExpression; 137 | var 138 | PPtr: PSEXPREC; 139 | pp: TProtectedPointer; 140 | begin 141 | if (ix < 0) or (ix >= VectorLength) then 142 | raise EopaRException.Create('Error: Vector index out of bounds'); 143 | 144 | pp := TProtectedPointer.Create(self); 145 | try 146 | PPtr := PSEXPREC(PPointerArray(DataPointer)^[ix]); 147 | 148 | if (PPtr = nil) or (PPtr = TEngineExtension(Engine).NilValue) then 149 | result := nil 150 | else 151 | result := TSymbolicExpression.Create(Engine, PPtr); 152 | finally 153 | pp.Free; 154 | end; 155 | end; 156 | //------------------------------------------------------------------------------ 157 | procedure TGenericVector.SetNames(const names: TArray); 158 | var 159 | cv: ICharacterVector; 160 | begin 161 | cv := TCharacterVector.Create(Engine, names); 162 | SetNames(cv); 163 | end; 164 | //------------------------------------------------------------------------------ 165 | procedure TGenericVector.SetNames(const names: ICharacterVector); 166 | var 167 | namesSymbol: ISymbolicExpression; 168 | p: PSEXPREC; 169 | begin 170 | if names.VectorLength <> VectorLength then 171 | raise EopaRException.Create('Error: Names vector must be same length as list.'); 172 | 173 | p := TEngineExtension(Engine).GetPredefinedSymbolPtr('R_NamesSymbol'); 174 | namesSymbol := TSymbolicExpression.Create(Engine, p); 175 | SetAttribute(namesSymbol, names as ISymbolicExpression); 176 | end; 177 | //------------------------------------------------------------------------------ 178 | //-- Note that TGenericVector does not get involved in any lifetime management 179 | //-- of TSymbolicExpression objects - in SetValue we just copy the pointer 180 | //-- value to the internal R vector. 181 | procedure TGenericVector.SetValue(ix: integer; value: ISymbolicExpression); 182 | var 183 | PData: PSEXPREC; 184 | pp: TProtectedPointer; 185 | begin 186 | if (ix < 0) or (ix >= VectorLength) then 187 | raise EopaRException.Create('Error: Vector index out of bounds'); 188 | 189 | pp := TProtectedPointer.Create(self); 190 | try 191 | if value = nil then 192 | PData := TEngineExtension(Engine).NilValue 193 | else 194 | PData := value.Handle; 195 | 196 | PPointerArray(DataPointer)^[ix] := PData; 197 | finally 198 | pp.Free; 199 | end; 200 | end; 201 | //------------------------------------------------------------------------------ 202 | procedure TGenericVector.SetVectorDirect(const values: TArray); 203 | var 204 | i: integer; 205 | begin 206 | for i := 0 to VectorLength - 1 do 207 | SetValue(i, values[i]); 208 | end; 209 | //------------------------------------------------------------------------------ 210 | function TGenericVector.ToPairlist: IPairlist; 211 | var 212 | p: PSEXPREC; 213 | begin 214 | p := Engine.Rapi.VectorToPairList(Handle); 215 | result := TPairList.Create(Engine, p); 216 | end; 217 | 218 | end. 219 | 220 | 221 | --------------------------------------------------------------------------------