diff --git a/.clang-format b/.clang-format deleted file mode 100644 index cf0bf57..0000000 --- a/.clang-format +++ /dev/null @@ -1,98 +0,0 @@ ---- -Language: Cpp -# BasedOnStyle: LLVM -AccessModifierOffset: -2 -AlignAfterOpenBracket: Align -AlignConsecutiveAssignments: false -AlignConsecutiveDeclarations: false -AlignEscapedNewlinesLeft: false -AlignOperands: true -AlignTrailingComments: true -AllowAllParametersOfDeclarationOnNextLine: true -AllowShortBlocksOnASingleLine: false -AllowShortCaseLabelsOnASingleLine: false -AllowShortFunctionsOnASingleLine: All -AllowShortIfStatementsOnASingleLine: false -AllowShortLoopsOnASingleLine: false -AlwaysBreakAfterDefinitionReturnType: None -AlwaysBreakAfterReturnType: None -AlwaysBreakBeforeMultilineStrings: false -AlwaysBreakTemplateDeclarations: false -BinPackArguments: true -BinPackParameters: true -BraceWrapping: - AfterClass: false - AfterControlStatement: false - AfterEnum: false - AfterFunction: false - AfterNamespace: false - AfterObjCDeclaration: false - AfterStruct: false - AfterUnion: false - BeforeCatch: false - BeforeElse: false - IndentBraces: false -BreakBeforeBinaryOperators: None -BreakBeforeBraces: Attach -BreakBeforeTernaryOperators: false -BreakConstructorInitializersBeforeComma: false -BreakAfterJavaFieldAnnotations: false -BreakStringLiterals: true -ColumnLimit: 80 -CommentPragmas: '^ IWYU pragma:' -BreakBeforeInheritanceComma: false -ConstructorInitializerAllOnOneLineOrOnePerLine: false -ConstructorInitializerIndentWidth: 4 -ContinuationIndentWidth: 4 -Cpp11BracedListStyle: false -DerivePointerAlignment: false -DisableFormat: false -ExperimentalAutoDetectBinPacking: false -FixNamespaceComments: true -ForEachMacros: [ foreach, Q_FOREACH, BOOST_FOREACH ] -IncludeCategories: - - Regex: '^"(llvm|llvm-c|clang|clang-c)/' - Priority: 2 - - Regex: '^(<|"(gtest|isl|json)/)' - Priority: 3 - - Regex: '.*' - Priority: 1 -IncludeIsMainRegex: '$' -IndentCaseLabels: false -IndentWidth: 2 -IndentWrappedFunctionNames: false -JavaScriptQuotes: Leave -JavaScriptWrapImports: true -KeepEmptyLinesAtTheStartOfBlocks: true -MacroBlockBegin: '' -MacroBlockEnd: '' -MaxEmptyLinesToKeep: 1 -NamespaceIndentation: None -ObjCBlockIndentWidth: 2 -ObjCSpaceAfterProperty: false -ObjCSpaceBeforeProtocolList: true -PenaltyBreakBeforeFirstCallParameter: 19 -PenaltyBreakComment: 300 -PenaltyBreakFirstLessLess: 120 -PenaltyBreakString: 1000 -PenaltyExcessCharacter: 1000000 -PenaltyReturnTypeOnItsOwnLine: 60 -PointerAlignment: Right -ReflowComments: true -SortIncludes: false -SpaceAfterCStyleCast: true -SpaceAfterTemplateKeyword: false -SpaceBeforeAssignmentOperators: false -SpaceBeforeParens: Never -SpaceInEmptyParentheses: false -SpacesBeforeTrailingComments: 1 -SpacesInAngles: false -SpacesInContainerLiterals: false -SpacesInCStyleCastParentheses: false -SpacesInParentheses: false -SpacesInSquareBrackets: false -Standard: Cpp11 -TabWidth: 8 -UseTab: Never -... - diff --git a/.gitignore b/.gitignore index bf9cabf..feeb709 100644 --- a/.gitignore +++ b/.gitignore @@ -35,6 +35,12 @@ *.x86_64 *.hex +# k.h +include/k.h + +# Package +build/ + # Debug files *.dSYM/ *.su diff --git a/.travis.yml b/.travis.yml index 8cd5ffa..5df9f2e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,23 +1,99 @@ +jobs: + include: + - dist: xenial + os: linux + - dist: bionic + os: linux + - os: osx +os: linux +dist: xenial language: c -os: -- linux -- osx +compiler: gcc + before_install: -- if [ $TRAVIS_OS_NAME = linux ]; then - sudo apt-get install r-base; - fi -- if [ $TRAVIS_OS_NAME = osx ]; then - export HOMEBREW_AUTO_UPDATING=0; - brew install --build-from-source r; - fi + # Set global flag + - export TESTS="True" + + # Install R + - if [[ $TRAVIS_OS_NAME == linux ]]; then + sudo apt-get install r-base; + elif [[ $TRAVIS_OS_NAME == osx ]]; then + export HOMEBREW_AUTO_UPDATING=0; + brew install --build-from-source r; + else + echo "$TRAVIS_OS_NAME is not supported"; + exit 1; + fi + + # Setup R directory. + - export R_LIBRARY_DIR=$(R RHOME)/lib + - export R_INCLUDE_DIR=$(R CMD config --cppflags | cut -c 3-) + - export LD_LIBRARY_PATH=${R_LIBRARY_DIR}:${LD_LIBRARY_PATH} + - export DYLD_LIBRARY_PATH=${R_LIBRARY_DIR}:${DYLD_LIBRARY_PATH} + + # Install q and set QHOME + - if [[ $TRAVIS_OS_NAME == "linux" ]]; then + QLIBDIR=l64; + OD=$L64; + elif [[ $TRAVIS_OS_NAME == "osx" ]]; then + QLIBDIR=m64; + OD=$M64; + elif [[ $TRAVIS_OS_NAME == "windows" ]]; then + QLIBDIR=w64; + OD=$W64; + else + echo "unknown OS ('$TRAVIS_OS_NAME')" >&2; exit 1; + fi + - export QLIBDIR + - mkdir qhome; + - export QHOME=$(pwd)/qhome; + - export PATH=$QHOME/$QLIBDIR:$PATH; + + # Set up q for testing and execute tests on multiple + - if [[ $TESTS == "True" && "x$OD" != "x" && "x$QLIC_KC" != "x" ]]; then + export PATH=$R_INSTALL_DIR/lib:$PATH; + curl -o ${QHOME}/q.zip -L $OD; + unzip -d ${QHOME} ${QHOME}/q.zip; + rm ${QHOME}/q.zip; + echo -n $QLIC_KC |base64 --decode > ${QHOME}/kc.lic; + else + echo "No kdb+, no tests"; + fi + + # Set package name + - if [[ $TRAVIS_OS_NAME == "windows" ]]; then + export FILE_TAIL="zip"; + else + export FILE_TAIL="tgz"; + fi + - export FILE_NAME=$FILE_ROOT-$TRAVIS_OS_NAME-$ARCH-$TRAVIS_BRANCH.$FILE_TAIL + + # Build package + - mkdir build + - cd build + - if [[ $TRAVIS_OS_NAME == windows ]]; then + cmake --config Release ..; + cmake --build . --config Release --target install; + else + cmake ..; + cmake --build . --target install; + fi + - cd .. + script: -- make -- echo "Preparing version $TRAVIS_BRANCH-$TRAVIS_COMMIT" -- mkdir embedr; cp -r rinit.q rtest.q l32 l64 m32 m64 embedr/ || true; -- echo "$TRAVIS_BRANCH-$TRAVIS_COMMIT" > embedr/VERSION.embedr; -- cp LICENSE embedr/LICENSE.embedr; cp README.md embedr/README.embedr; -- tar czvf embedr_$TRAVIS_OS_NAME-$TRAVIS_BRANCH.tar.gz embedr -- echo "Packaged as embedr_$TRAVIS_OS_NAME-$TRAVIS_BRANCH.tar.gz" + - if [[ $TESTS == "True" && "x$OD" != "x" && "x$QLIC_KC" != "x" ]]; then + q tests/test.q -test_data_frame false; + fi + - if [[ $TRAVIS_OS_NAME == "windows" && $BUILD == "True" ]]; then + 7z a -tzip -r $FILE_NAME ./build/$FILE_ROOT/*; + elif [[ $BUILD == "True" && ( $TRAVIS_OS_NAME == "linux" || $TRAVIS_OS_NAME == "osx" ) ]]; then + tar -zcvf $FILE_NAME -C build/$FILE_ROOT .; + elif [[ $TRAVIS_OS_NAME == "windows" ]]; then + 7z a -tzip $FILE_NAME README.md install.bat install32.bat LICENSE q examples; + elif [[ $TRAVIS_OS_NAME == "linux" || $TRAVIS_OS_NAME == "osx" ]]; then + tar -zcvf $FILE_NAME README.md install.sh LICENSE q examples; + fi + deploy: provider: releases token: "$GITHUB_APIKEY" @@ -25,4 +101,4 @@ deploy: file: embedr_*.tar.gz skip_cleanup: true on: - tags: true \ No newline at end of file + tags: true diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000..7d09ef6 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,32 @@ +##%% General Settings %%##vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv# + +cmake_minimum_required(VERSION 3.1) +project(embedr C) + +# Set library name +set(MY_LIBRARY_NAME embedr) + +# Add src directry +add_subdirectory(src) + +# Default option is Release +if(NOT CMAKE_BUILD_TYPE) + set(CMAKE_BUILD_TYPE Release) +endif() + +##%% Installation %%##vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv# + +# Install script +if(WIN32) + set(INSTALL_SCRIPT "install.bat") +else() + set(INSTALL_SCRIPT "install.sh") +endif() + +# Build package always +file(COPY README.md LICENSE ${INSTALL_SCRIPT} DESTINATION ${PROJECT_BINARY_DIR}/${CMAKE_PROJECT_NAME}) +file(COPY examples/ DESTINATION ${PROJECT_BINARY_DIR}/${CMAKE_PROJECT_NAME}/examples/) +file(COPY q/ DESTINATION ${PROJECT_BINARY_DIR}/${CMAKE_PROJECT_NAME}/q/) + +# Copy q files to QHOME +install(DIRECTORY q/ DESTINATION $ENV{QHOME}/ CONFIGURATIONS Release) diff --git a/Makefile b/Makefile deleted file mode 100644 index 0fad294..0000000 --- a/Makefile +++ /dev/null @@ -1,40 +0,0 @@ -# rserver makefile - -UNAME_S := $(shell uname -s) -ifeq ($(UNAME_S),Linux) - OSFLAG = l -endif -ifeq ($(UNAME_S),Darwin) - OSFLAG = m -endif -MS=$(shell getconf LONG_BIT) # 32/64 -QARCH=$(OSFLAG)$(MS) -Q=${QHOME}/$(QARCH) - -CFLAGS=-g -O0 -fPIC -m$(MS) -ifeq ($(OSFLAG),m) - CFLAGS+=-dynamiclib -undefined dynamic_lookup -endif -ifeq ($(OSFLAG),l) - CFLAGS+=-shared -endif - -R_HOME=$(shell R RHOME) -R_INCLUDES=$(shell R CMD config --cppflags) -LIBS=-lpthread -L$(R_HOME)/lib -lR - -SRC=embedr.c -TGT=$(addsuffix /embedr.so,$(QARCH)) - -all: - mkdir -p $(QARCH) - R CMD gcc -o $(TGT) $(CFLAGS) $(R_INCLUDES) $(SRC) $(LIBS) -Wall - -install: - install $(TGT) $(Q) - -clean: - rm -rf $(TGT) - -fmt: - clang-format -style=file embedr.c src/rserver.c src/qserver.c src/common.c -i diff --git a/README.md b/README.md index a4897f9..109d0fe 100644 --- a/README.md +++ b/README.md @@ -1,69 +1,132 @@ # embedR: Embedding R inside q +[![GitHub release (latest by date)](https://img.shields.io/github/v/release/kxsystems/embedr)](https://github.com/kxsystems/kafka/releases) [![Travis (.org) branch](https://img.shields.io/travis/kxsystems/embedr/master)](https://travis-ci.org/kxsystems/embedr/branches) +## Introduction -See +[](images/R_logo.png) While **kdb+** is good at pre-processing data it does not have native libraries to analyze scientifically. On the other hand, the programming language **R** is used for the very statistic analysis and therefore has numerous libraries. +This interface **embedR** embeds R process inside q process and allows user to call R functions from q process after passing data to R side with a simple function. ## Installation -### Download +### Download Pre-built Binary + Download the appropriate release archive from [releases](../../releases/latest) page. -### Unpack and install content of the archive +- Linux/Mac: -environment | action -----------------|--------------------------------------------------------------------------------------- -Linux | `tar xzvf embedr_linux-v*.tar.gz -C $QHOME --strip 1` -macOS | `tar xzvf embedr_osx-v*.tar.gz -C $QHOME --strip 1` -Windows | Open the archive and copy content of the `embedr` folder (`embedr\*`) to `%QHOME%` or `c:\q`
Copy R_HOME/x64/*.dll or R_HOME/i386/*.dll to QHOME/w64 or QHOME/w32 respectively. + $ install.sh +- Windows: -## Calling R + > install.bat + +### Install from Source + +Building the library from source uses the CMake file provided. + +#### Linux/ Mac -When calling R, you need to set `R_HOME`. Required are: +For successful installation you need to set a path to `lib` directory on `R_LIBRARY_DIR` and a path to `include` directory on `R_INCLUDE_DIR` with following commands: ```bash -# Linux/macOS -export R_HOME=`R RHOME` -# Windows -for /f "delims=" %a in ('R RHOME') do @set R_HOME=%a + +]$ export R_LIBRARY_DIR=$(R RHOME)/lib +]$ export R_INCLUDE_DIR=$(R CMD config --cppflags | cut -c 3-) + ``` -The library has four main methods: +Then execute the commands below at the root directory of this repository: -- `Ropen`: Initialise embedded R. Optional to call. Allows to set verbose mode as `Ropen 1`. -- `Rcmd`: run an R command, do not return a result -- `Rget`: run an R command, return the result to q -- `Rset`: set a variable in the R memory space +```bash +embedR]$ mkdir build && cd build +build]$ cmake .. +build]$ cmake --build . --target install -### Interactive plotting +``` -If using interactive plotting with `lattice` and/or `ggplot2` you will need to call `print` on a chart object. +**Note:** `cmake --build . --target install` installs the required share object and q files to the `QHOME\[os]64` and `QHOME` directories respectively. If you do not wish to install these files directly, you can execute `cmake --build .` instead of `cmake --build . --target install` and move the files from their build location at `build/embedr`. +#### Windows -## Examples +Set a path to `lib` directory on `R_LIBRARY_DIR` and a path to `include` directory on `R_INCLUDE_DIR` with following commands: + +```bat + +:: Example output as we don't know how to evaluate an expression... +> R RHOME +C:\PROGRA~1\R\R-36~1.3 +> set R_HOME=C:\PROGRA~1\R\R-36~1.3 +> set R_LIBRARY_DIR=%R_HOME%\bin\x64 +> set R_INCLUDE_DIR=%R_HOME%\include + +``` + +Next you need to create `R.lib` from `R.dll` in `R_LIBRARY_DIR` 🔨🔨🔨. This `R.lib` will be used for linking the interface. + +```bat -See [examples](examples) folder. +> cd %R_LIBRARY_DIR% +x64> echo EXPORTS > R.def +x64> for /f "usebackq tokens=4,* delims= " %i in (`dumpbin /exports "R.dll"`) do echo %i >> R.def +:: Then delete line 2-9 (garbage of header) manually so that `ALTCOMPLEX_ELT` comes next to `EXPORTS`. +:: After the manual processing, create lib file. +x64> lib /def:R.def /out:R.lib /machine:x64 -Note: Examples are kdb+ 3.5 or higher. +``` + +Then you need to create a symlink to `R.dll` and its sub R-related `.dll` files in the same directory (`Rblas.dll`, `Rgraphapp.dll`, `Riconv.dll` and `Rlapack.dll`). + +```bat +x64> cd %QHOME%\w64 +w64> MKLINK R.dll %R_LIBRARY_DIR%\R.dll +w64> MKLINK Rblas.dll %R_LIBRARY_DIR%\Rblas.dll +w64> MKLINK Rgraphapp.dll %R_LIBRARY_DIR%\Rgraphapp.dll +w64> MKLINK Riconv.dll %R_LIBRARY_DIR%\Riconv.dll +w64> MKLINK Rlapack.dll %R_LIBRARY_DIR%\Rlapack.dll + +``` -### Example 1 +Finally build embedR library by executing the commands below at the root directory of this repository on Visual Studio (assuming `-G "Visual Studio 15 2017 Win64"` is not necessary): -`e4.q` is a simple example of plot 'moving window volatility' of returns. Converted from http://www.mayin.org/ajayshah/KB/R/html/p4.html +```bat +embedR> mkdir build && cd build +build> cmake --config Release .. +build> cmake --build . --config Release --target install -### Example 2 +``` + +**Note:** `cmake --build . --config Release --target install` installs the required share object and q files to the `QHOME\w64` and `QHOME` directories respectively. If you do not wish to install these files directly, you can execute `cmake --build . --config Release` instead of `cmake --build . --config Release --target install` and move the files from their build location at `build/embedr`. + +## Calling R -`pcd.q` is based on [Corporate credit card transactions 2014-15](https://data.gov.uk/dataset/corporate-credit-card-transaction-2014-15). -Download CSV from the link above and save it in the same folder as `pcd.q` under name `pcd2014v1.csv`. +The library has four main methods: + +- `.r.open`: Initialise embedR. Optional to call. Allows to set verbose mode as `.r.open 1`. +- `.r.exec`: Execute an R command, do not return a result to q. +- `.r.get`: Execute an R command, return the result to q. +- `.r.set`: Set a variable in the R memory space. + + +## Documentation + +Documentation for this interface is available [here](https://code.kx.com/q/interfaces/r/embedr) + +## Examples + +A number of example scripts are provided in the [examples](examples) folder. +**Note:** Examples are kdb+ 3.5 or higher. -### Example 3 +1. Plotting the 'moving window volatility' of returns +2. Analysis of corporate credit card transactions in the UK dataset available [here](https://ckan.publishing.service.gov.uk/dataset/corporate-credit-card-transactions-2014-152) - +## Notes -Left for the reader :) +1. If using interactive plotting with `lattice` and/or `ggplot2` you will need to call `print` on a chart object. +2. As of v2.0 the callable functions have migrated to the `.rk` namespace in line with the other fusion interfaces. The historic interface using `Rcmd`,`Ropen` etc will be deprecated in v2.1 diff --git a/appveyor.yml b/appveyor.yml deleted file mode 100644 index c9bce7a..0000000 --- a/appveyor.yml +++ /dev/null @@ -1,46 +0,0 @@ -image: Visual Studio 2017 -# Download script file from GitHub -init: - ps: | - $ErrorActionPreference = "Stop" - Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" - Import-Module '..\appveyor-tool.ps1' - -install: - ps: Bootstrap - -environment: - global: - GCC_PATH: mingw_64 - matrix: - - BITS: 64 - R_ARCH: x64 - - - BITS: 32 - R_ARCH: i386 - -build_script: -- cmd: mkdir w%BITS% -- cmd: R.exe CMD SHLIB -o w%BITS%/embedr.dll embedr.c src/w%BITS%/q.a -lws2_32 - -after_build: -- cmd: mkdir embedr -- ps: Copy-Item w$env:BITS -Destination .\embedr\w$env:BITS -Recurse -- ps: Copy-Item rinit.q -Destination .\embedr -- ps: Copy-Item rtest.q -Destination .\embedr -- ps: Copy-Item LICENSE -Destination .\embedr\LICENSE.embedr -- ps: Copy-Item README.md -Destination .\embedr\README.embedr -- IF /I "%APPVEYOR_REPO_TAG%" == "false" set APPVEYOR_REPO_TAG_NAME=%APPVEYOR_REPO_BRANCH% -- cmd: 7z a embedr_win%BITS%-%APPVEYOR_REPO_TAG_NAME%.zip %APPVEYOR_BUILD_FOLDER%\embedr -artifacts: -- path: 'embedr_win*.zip' - -deploy: - provider: GitHub - draft: true - auth_token: - secure: P2U9jL8L7es2Iv/SSthmQ+a9qSZ41OSiGHjSdOMve7eKwWoo3zh/8DvJqkkMfhS7 - prerelease: true - on: - branch: master # release from master branch only - appveyor_repo_tag: true # deploy on tag push only diff --git a/docs/examples.md b/docs/examples.md new file mode 100644 index 0000000..25405ad --- /dev/null +++ b/docs/examples.md @@ -0,0 +1,79 @@ +--- +title: embedR Examples +date: April 2020 +description: Examples of embedR +keywords: interface, kdb+, q, r, +--- + +# embedR Examples + +An example is outlined below, using q to subselect some data and then passing it to R for graphical display. + +```q +q)select count i by date from trade +date | x +----------| -------- +2014.01.07| 29205636 +2014.01.08| 30953246 +2014.01.09| 30395962 +2014.01.10| 29253110 +2014.01.13| 32763630 +2014.01.14| 29721162 +2014.01.15| 30035729 +.. + +q)//extract mid prices in 5 minute bars +q)mids:select mid:last .5*bid+ask by time:0D00:05 xbar date+time from quotes where date=2014.01.17,sym=`IBM,time within 09:30 16:00 +q)mids +time | mid +-----------------------------| -------- +2014.01.15D09:30:00.000000000| 185.92 +2014.01.15D09:35:00.000000000| 185.74 +2014.01.15D09:40:00.000000000| 186.11 +2014.01.15D09:45:00.000000000| 186.36 +2014.01.15D09:50:00.000000000| 186.5 +2014.01.15D09:55:00.000000000| 186.98 +2014.01.15D10:00:00.000000000| 187.45 +2014.01.15D10:05:00.000000000| 187.48 +2014.01.15D10:10:00.000000000| 187.66 +.. + +q)Load in R +q)\l init.q +q)//Pass the table into the R memory space +q).r.set["mids";mids] +q)//Graph it +q).r.exec["plot(mids$time, mids$mid, type='l', xlab='time', ylab='price')"] +``` + +This will produce a plot as shown in Figure 4: + +![Quote mid price plot drawn from q](../images/figure4.svg) +_Figure 4: Quote mid price plot drawn from q_ + +```q +q)//Save as a PDF file +q).r.exec "pdf('test.pdf')" +q)//Close plot window +q).r.off[] +``` + +If the q and R installations are running remotely from the user on a Linux machine, the graphics can be seen locally using X11 forwarding over SSH. + +Aside from using R’s powerful graphics, this mechanism also allows you to call R analytics from within q. + +Note that R’s timezone setting affects date transfers between R and q. For example, in the R server: + +```q +q).r.exec "Sys.setenv(TZ='GMT')" +q).r.get "date()" +"Fri Feb 3 06:33:43 2012" +q).r.exec "Sys.setenv(TZ='EST')" +q).r.get "date()" +"Fri Feb 3 01:33:57 2012" +``` + + +Knowledge Base: [Timezones and Daylight Saving Time]([../../kb/timezones.md](https://code.kx.com/q/kb/timezones/)) + +Further examples are provided in the `examples` folder of [KxSystems/embedR](https://github.com/KxSystems/embedR). \ No newline at end of file diff --git a/docs/index.md b/docs/index.md new file mode 100644 index 0000000..36566a1 --- /dev/null +++ b/docs/index.md @@ -0,0 +1,87 @@ +--- +title: embedR, an interface for calling R from q +description: embedR is an interface that allows the R programming language to be invoked by q programs +keywords: interface, kdb+, q, r +hero: Fusion for Kdb+ +--- + +# embedR + +## Introduction + +Kdb+ and R are complementary technologies. Kdb+ is the world’s leading timeseries database and incorporates a programming language called q. [R](https://www.r-project.org/) is a programming language and environment for statistical computing and graphics. Both are tools used by data scientists to interrogate and analyze data. Their features sets overlap in that they both: + +- are interactive development environments +- incorporate vector languages +- have a built-in set of statistical operations +- can be extended by the user +- are well suited for both structured and ad-hoc analysis + +They do however have several differences: + +- q can store and analyze petabytes of data directly from disk whereas R is limited to reading data into memory for analysis +- q has a larger set of datatypes including extensive temporal times (timestamp, timespan, time, second, minute, date, month) which make temporal arithmetic straightforward +- R contains advanced graphing capabilities whereas q does not +- built-in routines in q are generally faster than R +- R has a more comprehensive set of pre-built statistical routines + +When used together, q and R provide an excellent platform for easily performing advanced statistical analysis and visualization on large volumes of data. + +R can be called as a server from q, and vice-versa. + +### q and R working together + +Given the complementary characteristics of the two languages, it is important to utilize their respective strengths. +All the analysis could be done in q; the q language is sufficiently flexible and powerful to replicate any of the pre-built R functions. +Below are some best practice guidelines, although where the line is drawn between q and R will depend on both the system architecture and the strengths of the data scientists using the system. + +- Do as much of the analysis as possible in q. This is because q analyzes the data directly from the disk and it is always most efficient to do as much work as possible as close to the data as possible. Whenever possible, avoid extracting large raw datasets from q and if extractions are required, use q to create smaller aggregated datasets +- Do not re-implement tried and tested R routines in q unless they either + * can be written more efficiently in q and are going to be called often + * require more data than is feasible to ship to the R installation +- Use R for data visualization + +Considering the potential size of the data, it is probably more likely that the kdb+ installation containing the data will be hosted remotely from the user. + +### What Does embedR Provide? + +What **embedR** provides is to embed R inside q and invoke R routines. can only be used if the q and R installations are installed on the same server. + +## Install + +Work for both 32-bit and 64-bit kdb+. + +Pre-built packages are available from [here](https://github.com/KxSystems/embedR/releases/tag/v1.2.1) for: + +- Linux +- macOS + +If the appropriate build is not available on your target system, download from [KxSystems/embedR](https://github.com/KxSystems/embedR) and follow the installation instruction in `README.md`. + +## Testing + +User can test embedR with the test script named `test.q` provided in `tests` folder of [KxSystems/embedR](https://github.com/KxSystems/embedR). + +Procedure is simple. Go to `tests` directory and run `test.q`. + +**Note:** If you don't have multi-threading environment eliminate `-s 2` flag. + +```bash +$ cd embedR/tests +$ q test.q -test_data_frame true -s 2 +0i + ++-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+- + Test Start!! + Score: 0/0 + Fail: 0/0 ++-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+- + +... + ++-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+- + Completed!! + Score: 78/78 + Fail: 0/78 ++-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+- +``` diff --git a/docs/reference.md b/docs/reference.md new file mode 100644 index 0000000..e24445b --- /dev/null +++ b/docs/reference.md @@ -0,0 +1,224 @@ +--- +title: embedR User Guide +date: April 2020 +description: Lists functions available for use within the embedR +keywords: interface, kdb+, q, r, +--- + +# embedR User Guide + +A shared library can be loaded which brings R into the q memory space, +meaning all the R statistical routines and graphing capabilities can be invoked directly from q. +Using this method means data is not passed between remote processes. + +The library has five methods: + +```txt + //Connection + .r.open: Initialise embedR. Optional to call. Allows to set verbose mode as Ropen 1 + .r.close: Close internal R connection + + //Execution + .r.exec: Run an R command, do not return a result + .r.get: Run an R command, return the result to q + .r.set: Set a variable in the R memory space + + //Graphic + .r.dev Open plot window with noRStudioGD=TRUE (Normally R will open a new device automatically) + .r.off Close plot window + + //Utility + .r.install Install package in embeded R process over the connection + +``` + +## Connection + +### .r.open + +_Initialise embedR. Optional to call. Allows to set verbose mode as Ropen 1_ + +Syntax: `.r.open[signal]` + +Where + +- `signal` is an integer which is one of empty, 0 or 1. + * 0 or empty: quiet mode + * 1: verbose mode + +```q +q).r.open[] +q)//or +q).r.open[1] +``` + +!!! note "Note" + + As of version 2.0 Ropen was migrated to .r.open. Ropen will be depricated in version 2.1. + +### .r.close + +_Close internal R connection_ + +Syntax: `.r.close[]` + +!!! note "Note" + + As of version 2.0 Rclose was migrated to .r.close. Rclose will be depricated in version 2.1. + +## Execution + +### .r.exec + +_Run an R command, do not return a result_ + +Synatax: `.r.exec[command]` + +Where + +- `command` is an R expression to execute in R process + +```q +q).r.exec "Sys.setenv(TZ = 'UTC')" +q).r.exec "library(xts)" +Loading required package: zoo + +Attaching package: ‘zoo’ + +The following objects are masked from ‘package:base’: + + as.Date, as.Date.numeric +``` + +### .r.get + +_Run an R command, return the result to q_ + +Synatax: `.r.get[rexp]` + +Where + +- `rexp` is a string denoting an R expression to execute in R process + +```q +q).r.exec "today <- as.Date('2020-04-01')" +q).r.get "today" +,2019.04.01 +``` + +!!! note "Note" + + As of version 2.0 Rget was migrated to .r.get. Rget will be depricated in version 2.1. + +### .r.set + +_Set a variable in the R memory space_ + +Synatax: `.r.set[rvar; qvar]` + +Where + +- `rvar` is a string denoting a name of R variable used in R process +- `qvar` is any q object used to assign to the R variable in R process + +```q +q).r.set["mnth"; `month$/:2010.01.29 2020.04.02] +q).r.get "mnth" +2010.01 2020.04m +``` + +!!! note "Note" + + As of version 2.0 Rset was migrated to .r.set. Rset will be depricated in version 2.1. + +## Graphic + +### .r.new + +_Open plot window with noRStudioGD=TRUE (Normally R will open a new device automatically)_ + +Syntax: `.r.new[]` + +!!! note "Note" + + As of version 2.0 Rnew was migrated to .r.new. Rnew will be depricated in version 2.1. + +### .r.off + +_Close plot window_ + +Syntax: `.r.off[]` + +To close the graphics window, use `dev.off()` rather than the close button on the window. + +!!! note "Note" + + As of version 2.0 Roff was migrated to .r.off. Roff will be depricated in version 2.1. + +## Utility + +### .r.install + +_Install package in embeded R process over the connection_ + +Syntax: `.r.install[package]` + +Where + +- `package` is a symbol denoting the name of a package to install in the R process + +You must be a super user who has an access to the library directory. + +The result is any information regarding install if the package is installed for the first time; otherwise nothing is returned. + +```q +q).r.install["psy"] +Installing package into ‘/usr/lib64/R/library’ +(as ‘lib’ is unspecified) +trying URL 'https://cloud.r-project.org/src/contrib/psy_1.1.tar.gz' +Content type 'application/x-gzip' length 36107 bytes (35 KB) +================================================== +downloaded 35 KB + +* installing *source* package ‘psy’ ... +** package ‘psy’ successfully unpacked and MD5 sums checked +** using staged installation +** R +** data +** byte-compile and prepare package for lazy loading +** help +*** installing help indices + converting help for package ‘psy’ + finding HTML links ... done + ckappa html + cronbach html + ehd html + expsy html + fpca html + icc html + lkappa html + mdspca html + mtmm html + psy-package html + scree.plot html + sleep html + sphpca html + wkappa html +** building package indices +** testing if installed package can be loaded from temporary location +** testing if installed package can be loaded from final location +** testing if installed package keeps a record of temporary installation path +* DONE (psy) +Making 'packages.html' ... done + +The downloaded source packages are in + ‘/tmp/Rtmp8Pnq5n/downloaded_packages’ +Updating HTML index of packages in '.Library' +``` + +!!! note "Note" + + As of version 2.0 Rinstall was migrated to .r.install. Rinstall will be depricated in version 2.1. + + +Simple examples of embedR are available in [Examples](examples.md) page. \ No newline at end of file diff --git a/embedr.c b/embedr.c deleted file mode 100644 index 25f0553..0000000 --- a/embedr.c +++ /dev/null @@ -1,30 +0,0 @@ -/* - * This library provides an R server for Q - */ -#include -#include -#include -#include -#include -#include -#ifndef WIN32 -#include -#include -#include -#include -//#include -#else -#include -#include -#endif - -#include -#include "src/socketpair.c" - -#define KXVER 3 -#include "src/k.h" - -#include "src/common.c" -#include "src/rserver.c" - -int R_SignalHandlers = 0; diff --git a/examples/e4.q b/examples/e4.q index 9e24f51..6b5a38d 100644 --- a/examples/e4.q +++ b/examples/e4.q @@ -1,34 +1,37 @@ // Goal: To do `moving window volatility' of returns. // http://www.mayin.org/ajayshah/KB/R/html/p4.html -//\l rtest.q // check if lib installed -if[0i=first Rget"is.element(\"zoo\",installed.packages()[,1])";Rcmd"install.packages(\"zoo\",repos=\"https://cloud.r-project.org\")"] -Rcmd"library(zoo)"; + +\l ../init.q + +if[0i=first .r.get"is.element(\"zoo\",installed.packages()[,1])"; + .r.exec"install.packages(\"zoo\",repos=\"https://cloud.r-project.org\")"] +.r.exec"library(zoo)"; // Some data to play with (Nifty on all fridays for calendar 2004) -- pr:1946.05 1971.9 1900.65 1847.55 1809.75 1833.65 1913.6 1852.65 1800.3 1867.7 1812.2 1725.1 1747.5 1841.1 1853.55 1868.95 1892.45 1796.1 1804.45 1582.4 1560.2 1508.75 1521.1 1508.45 1491.2 1488.5 1537.5 1553.2 1558.8 1601.6 1632.3 1633.4 1607.2 1590.35 1609 1634.1 1668.75 1733.65 1722.5 1775.15 1820.2 1795 1779.75 1786.9 1852.3 1872.95 1872.35 1901.05 1996.2 1969 2012.1 2062.7 2080.5 d: 2004.01.02 2004.01.09 2004.01.16 2004.01.23 2004.01.30 2004.02.06 2004.02.13 2004.02.20 2004.02.27 2004.03.05 2004.03.12 2004.03.19 2004.03.26 2004.04.02 2004.04.09 2004.04.16 2004.04.23 2004.04.30 2004.05.07 2004.05.14 2004.05.21 2004.05.28 2004.06.04 2004.06.11 2004.06.18 2004.06.25 2004.07.02 2004.07.09 2004.07.16 2004.07.23 2004.07.30 2004.08.06 2004.08.13 2004.08.20 2004.08.27 2004.09.03 2004.09.10 2004.09.17 2004.09.24 2004.10.01 2004.10.08 2004.10.15 2004.10.22 2004.10.29 2004.11.05 2004.11.12 2004.11.19 2004.11.26 2004.12.03 2004.12.10 2004.12.17 2004.12.24 2004.12.31 -Rset[`d;d] -Rset[`pr;pr] -Rcmd"p <- structure(pr, index = d, frequency = 0.142857142857143, class = c(\"zooreg", "zoo\"))"; +.r.set[`d;d] +.r.set[`pr;pr] +.r.exec"p <- structure(pr, index = d, frequency = 0.142857142857143, class = c(\"zooreg", "zoo\"))"; // Shift to returns -- -Rcmd"r <- 100*diff(log(p))"; -Rget"head(r)" -Rget"summary(r)" -Rget"sd(r)" +.r.exec"r <- 100*diff(log(p))"; +.r.get"head(r)" +.r.get"summary(r)" +.r.get"sd(r)" // Compute the moving window vol -- -Rcmd"vol <- sqrt(250) * rollapply(r, 20, sd, align = \"right\")"; +.r.exec"vol <- sqrt(250) * rollapply(r, 20, sd, align = \"right\")"; // A pretty plot -- -Rcmd"png('pretty_plot_test.png')"; -Rcmd"plot(vol, type=\"l\", ylim=c(0,max(vol,na.rm=TRUE)),lwd=2, col=\"purple\", xlab=\"2004\",ylab=paste(\"Annualised sigma, 20-week window\"))"; -Rcmd"grid()"; -Rget"legend(x=\"bottomleft\", col=c(\"purple\", \"darkgreen\"),lwd=c(2,2), bty=\"n\", cex=0.8,legend=c(\"Annualised 20-week vol (left scale)\", \"Nifty (right scale)\"))" -Rcmd"par(new=TRUE)"; -Rcmd"plot(p, type=\"l\", lwd=2, col=\"darkgreen\", xaxt=\"n\", yaxt=\"n\", xlab=\"\", ylab=\"\")"; -Rcmd"axis(4)"; -Roff[] +.r.exec"png('pretty_plot_test.png')"; +.r.exec"plot(vol, type=\"l\", ylim=c(0,max(vol,na.rm=TRUE)),lwd=2, col=\"purple\", xlab=\"2004\",ylab=paste(\"Annualised sigma, 20-week window\"))"; +.r.exec"grid()"; +.r.get"legend(x=\"bottomleft\", col=c(\"purple\", \"darkgreen\"),lwd=c(2,2), bty=\"n\", cex=0.8,legend=c(\"Annualised 20-week vol (left scale)\", \"Nifty (right scale)\"))" +.r.exec"par(new=TRUE)"; +.r.exec"plot(p, type=\"l\", lwd=2, col=\"darkgreen\", xaxt=\"n\", yaxt=\"n\", xlab=\"\", ylab=\"\")"; +.r.exec"axis(4)"; +.r.off[] hcount `:pretty_plot_test.png //hdel `:pretty_plot_test.png diff --git a/examples/pcd.q b/examples/pcd.q index be0fcda..ea5a622 100644 --- a/examples/pcd.q +++ b/examples/pcd.q @@ -1,4 +1,4 @@ -//\l rinit.q +\l ../init.q basedir:`:.^hsym `$last -2 _ get{} datafile:` sv first[` vs basedir],`pcd2014v1.csv @@ -9,20 +9,20 @@ system"z 1" cct:("***D*DE";enlist csv) 0:datafile cct:(`$"_"^string cols cct) xcol cct -Rcmd"library(lattice)" -Rnew[] -Rset["tpd";select txn:count i by Transaction_Date from cct] -Rcmd"plot1<-xyplot(txn~Transaction_Date,data=tpd,main='Payments per day')" -Rcmd"print(plot1)" +.r.exec"library(lattice)" +.r.new[] +.r.set["tpd";select txn:count i by Transaction_Date from cct] +.r.exec"plot1<-xyplot(txn~Transaction_Date,data=tpd,main='Payments per day')" +.r.exec"print(plot1)" -Rset[`tpt;select Transaction_Date,spent:sums JV_Value from select sum JV_Value by Transaction_Date from cct] -Rnew[] -Rcmd"plot2<-xyplot(spent~Transaction_Date,data=tpt,main='Total spent')" -Rcmd"print(plot2)" +.r.set[`tpt;select Transaction_Date,spent:sums JV_Value from select sum JV_Value by Transaction_Date from cct] +.r.new[] +.r.exec"plot2<-xyplot(spent~Transaction_Date,data=tpt,main='Total spent')" +.r.exec"print(plot2)" -Rinstall`plotly -Rcmd"library(plotly)" -Rset[`catd;select sum JV_Value by Service_Area from cct] -Rcmd"plot3<-plot_ly(catd, labels = ~Service_Area, values = ~JV_Value, type = 'pie')" -Rcmd"print(plot3)" \ No newline at end of file +.r.install`plotly +.r.exec"library(plotly)" +.r.set[`catd;select sum JV_Value by Service_Area from cct] +.r.exec"plot3<-plot_ly(catd, labels = ~Service_Area, values = ~JV_Value, type = 'pie')" +.r.exec"print(plot3)" diff --git a/images/R_logo.png b/images/R_logo.png new file mode 100644 index 0000000..0fae873 Binary files /dev/null and b/images/R_logo.png differ diff --git a/images/figure4.svg b/images/figure4.svg new file mode 100644 index 0000000..b3e75ae --- /dev/null +++ b/images/figure4.svg @@ -0,0 +1,146 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/include/common_R_interface/common.h b/include/common_R_interface/common.h new file mode 100644 index 0000000..2d3b72f --- /dev/null +++ b/include/common_R_interface/common.h @@ -0,0 +1,100 @@ +/** + * Common headers for integration with R. + */ + +/*-----------------------------------------------*/ +/* Load Libraries */ +/*-----------------------------------------------*/ + +#include +#include +#include +#include +#include +#include +#include "k.h" + +/*-----------------------------------------------*/ +/* Macro */ +/*-----------------------------------------------*/ + +#define INT64(x) ((J*) REAL(x)) + +/*-----------------------------------------------*/ +/* Global Variable */ +/*-----------------------------------------------*/ + +// Offsets used in conversion between R and q +extern const J epoch_offset; +// Seconds in a day +extern const int sec2day; +// Days between 1970.01.01 & 2000.01.01 +extern const int kdbDateOffset; +// Seconds between 1970.01.01 & 2000.01.01 +extern const int kdbSecOffset; + +/** + * @brief Attribute set to q time related types when it is converted to R object. + */ +extern SEXP R_UnitsSymbol; +/** + * @brief Attribute set to q time related types when it is converted to R object. + */ +extern SEXP R_TzSymbol; + +/*-----------------------------------------------*/ +/* Functions */ +/*-----------------------------------------------*/ + +// Utility //-------------------------------------/ + +/** + * @brief Check if it is a leap year. + */ +bool is_leap(const int year); + +/** + * @brief Functions to derive day count since kdb+ epoch from month count + */ +int months2days(const int monthcount); + +/** + * @brief Functions to derive month count since kdb epoch from day count + */ +int days2months(const int daycount); + +// R -> q //--------------------------------------/ + +/** + * @brief Entry point of converting R object to q object. + */ +K from_any_robject(SEXP sxp); + +/** + * @brief Convert R pair-list object to q dictionary object. + * @note + * The definition varies between embedR and rkdb. + */ +K from_pairlist_robject(SEXP sxp); + +/** + * @brief add attribute if any. + **/ +K attR(K x,SEXP sxp); + +// q -> R //--------------------------------------/ + +/** + * @brief Entry point of converting q object to R object. + */ +SEXP from_any_kobject(K x); + +/** + * @brief Convert R string to q object. + */ +SEXP from_string_kobject(K); + +/** + * @brief Convert R symbol object to q object. + */ +SEXP from_symbol_kobject(K); diff --git a/include/embedr.h b/include/embedr.h new file mode 100644 index 0000000..5ff3458 --- /dev/null +++ b/include/embedr.h @@ -0,0 +1,24 @@ +/* + * This library provides an R server for Q + */ + +/*-----------------------------------------------*/ +/* Load Libraries */ +/*-----------------------------------------------*/ + +#include +#include +#include + +#ifdef _WIN32 +#include +#include +#define EXP __declspec(dllexport) +#else +#include +#include +#include +#include +#define EXP +#endif +#include diff --git a/include/socketpair.h b/include/socketpair.h new file mode 100644 index 0000000..7360ff5 --- /dev/null +++ b/include/socketpair.h @@ -0,0 +1,40 @@ +/* + * socketpair.h + * Header file of socketpair.c + * Created to ensure defining functions only once. + */ + +#ifndef __SOCKETPAIR_H__ +#define __SOCKETPAIR_H__ + +#include + +#ifdef _WIN32 +#define _WINSOCK_DEPRECATED_NO_WARNINGS +# include +# include +# include +# include +#else +# include +# include + +#endif + +#ifdef _WIN32 + +/** + * @brief If make_overlapped is nonzero, both sockets created will be usable for + * "overlapped" operations via WSASend etc. If make_overlapped is zero, + * socks[0] (only) will be usable with regular ReadFile etc., and thus + * suitable for use as stdin or stdout of a child process. Note that the + * sockets must be closed with closesocket() regardless. + */ +int dumb_socketpair(SOCKET socks[2], int make_overlapped); + +#else +int dumb_socketpair(int socks[2], int dummy); +#endif + +// __SOCKETPAIR_H__ +#endif \ No newline at end of file diff --git a/install.bat b/install.bat new file mode 100644 index 0000000..3b8bf0e --- /dev/null +++ b/install.bat @@ -0,0 +1,33 @@ +@echo off + +IF "%QHOME%"=="" ( + ECHO ERROR: Enviroment variable QHOME is NOT defined + EXIT /B +) + +IF NOT EXIST %QHOME%\w64 ( + ECHO ERROR: Installation destination %QHOME%\w64 does not exist + EXIT /B +) + + +IF EXIST q ( + ECHO Copying q script to %QHOME% + COPY q\* %QHOME% + IF %ERRORLEVEL% NEQ 0 ( + ECHO ERROR: Copy failed + EXIT /B %ERRORLEVEL% + ) +) + +IF EXIST lib ( + ECHO Copying DLL to %QHOME%\w64 + COPY lib\* %QHOME%\w64\ + IF %ERRORLEVEL% NEQ 0 ( + ECHO ERROR: Copy failed + EXIT /B %ERRORLEVEL% + ) +) + +ECHO Installation complete + diff --git a/install.sh b/install.sh new file mode 100644 index 0000000..3efd80c --- /dev/null +++ b/install.sh @@ -0,0 +1,87 @@ +#!/bin/bash + +## @file install.sh +## @fileoverview Install shared object to `${QHOME}/[os-bitness]` and q scripts to `${QHOME}`. + +if [ -z "$QHOME" ] +then + echo "ERROR: QHOME environment not set. Installation failed." + exit 1 +fi + +echo "Detected System" +echo "* OS: $OSTYPE" +echo "* TYPE: $HOSTTYPE" +echo "* MACHINE TYPE: $MACHTYPE" + +# DETECT OS TYPE BEING USED +Q_PATH_SEP="/" +Q_HOST_TYPE="" +if [[ "$OSTYPE" == "linux-gnu" ]]; then + Q_HOST_TYPE="l" +elif [[ "$OSTYPE" == "darwin"* ]]; then + # Mac OSX + Q_HOST_TYPE="m" +elif [[ "$OSTYPE" == "cygwin" ]]; then + # POSIX compatibility layer and Linux environment emulation for Windows + Q_HOST_TYPE="w" + Q_PATH_SEP="\\" +elif [[ "$OSTYPE" == "msys" ]]; then + # Lightweight shell and GNU utilities compiled for Windows (part of MinGW) + Q_HOST_TYPE="w" + Q_PATH_SEP="\\" +elif [[ "$OSTYPE" == "win32" ]]; then + Q_HOST_TYPE="w" + Q_PATH_SEP="\\" +elif [[ "$OSTYPE" == "freebsd"* ]]; then + Q_HOST_TYPE="l" +else + echo "ERROR: OSTYPE $OSTYPE not currently supported by this script" + echo "Please view README.md for installation instructions" + exit 1 +fi + +# DETECT WHETHER 32 OR 64 BIT +Q_MACH_TYPE="" +if [[ "$HOSTTYPE" == "x86_64" ]]; then + Q_MACH_TYPE="64" +else + Q_MACH_TYPE="32" +fi + +Q_SCRIPT_DIR=${QHOME}${Q_PATH_SEP} +Q_SHARED_LIB_DIR="${QHOME}${Q_PATH_SEP}${Q_HOST_TYPE}${Q_MACH_TYPE}${Q_PATH_SEP}" + +# check destination directory exists +if [ ! -w "$Q_SCRIPT_DIR" ]; then + echo "ERROR: Directory '$Q_SCRIPT_DIR' does not exist" + exit 1 +fi +if [ ! -w "$Q_SHARED_LIB_DIR" ]; then + echo "ERROR: Directory '$Q_SHARED_LIB_DIR' does not exist" + exit 1 +fi +if [ ! -d q ]; then + echo "ERROR: Directory 'q' does not exist. Please run from release package" + exit 1 +fi +if [ ! -d lib ]; then + echo "ERROR: Directory 'lib' does not exist. Please run from release package" + exit 1 +fi + +echo "Copying q script to $Q_SCRIPT_DIR ..." +cp q/* $Q_SCRIPT_DIR +if [ $? -ne 0 ]; then + echo "ERROR: copy failed" + exit 1 +fi +echo "Copying shared lib to $Q_SHARED_LIB_DIR ..." +cp lib/* $Q_SHARED_LIB_DIR +if [ $? -ne 0 ]; then + echo "ERROR: copy failed" + exit 1 +fi + +echo "Install complete" +exit 0 \ No newline at end of file diff --git a/q/embedr.q b/q/embedr.q new file mode 100644 index 0000000..60f8bce --- /dev/null +++ b/q/embedr.q @@ -0,0 +1,99 @@ +/ +* @file embedr.q +* @overview +* Define interface functions of embedR. +\ + +/*-----------------------------------------------*/ +/* Initial Setting */ +/*-----------------------------------------------*/ + +setenv[`R_HOME;first @[system;$[.z.o like "w*";"call";"env"]," R RHOME";enlist""]]; + +LIBPATH:`:embedr 2: + +/*-----------------------------------------------*/ +/* Load Libraries */ +/*-----------------------------------------------*/ + +.r.close: LIBPATH (`rclose;1); +.r.open: LIBPATH (`ropen;1); +.r.exec: LIBPATH (`rexec;1); +.r.get: LIBPATH (`rget;1); +.r.set: LIBPATH (`rset;2) + +/*-----------------------------------------------*/ +/* Additional Functions */ +/*-----------------------------------------------*/ + +.r.install:{[pkg] + pkg:$[-11=type pkg;string pkg;pkg]; + rcloud:"https://cloud.r-project.org"; + if[0i=first .r.get"is.element('",pkg,"',installed.packages()[,1])"; + .r.exec"install.packages('",pkg,"',repos='",rcloud,"',dependencies = TRUE)"]; + } +.r.off:{.r.exec "dev.off()"} +.r.new:{.r.exec "dev.new(noRStudioGD=TRUE)"} + +/*-----------------------------------------------*/ +/* Deprecated Function */ +/*-----------------------------------------------*/ + +// The following block of functions are aliases for the above +// these aliases will be removed in a future version of the code + +Ropen :.r.open; +Rclose :.r.close; +Rcmd :.r.exec; +Rget :{[variable] + result:.r.get[variable]; + $[ + // Foreign type + 112h ~ type result; + result; + // Table has extra column + 98h ~ type result; + update row.names:1+i from result; + // bool -> int, month -> int, datetime -> timestamp, timespan -> float, minute -> int, second -> int + any 1 13 15 16 17 18h in key typemap:group abs type each result; + [ + if[count typemap 1h; + $[99h ~ type result; + result:` _ @[(enlist[`]!enlist (::)), result; typemap 1h; `int$]; + result:1 _ @[(::), result; 1+typemap 1h; `int$] + ] + ]; + if[count typemap 13h; + $[99h ~ type result; + result:` _ @[(enlist[`]!enlist (::)), result; typemap 13h; `int$]; + result:1 _ @[(::), result; 1+typemap 13h; `int$] + ] + ]; + if[count typemap 15h; + $[99h ~ type result; + result:` _ @[(enlist[`]!enlist (::)), result; typemap 15h; `timestamp$]; + result:1 _ @[(::), result; 1+typemap 15h; `timestamp$] + ] + ]; + if[count typemap 16h; + $[99h ~ type result; + result:` _ @[(enlist[`]!enlist (::)), result; typemap 16h; {[timespan] 86400 * timespan % 1D}]; + result:1 _ @[(::), result; 1+typemap 16h; {[timespan] 86400 * timespan % 1D}] + ] + ]; + if[sum count each typemap 17 18h; + $[99h ~ type result; + result:` _ @[(enlist[`]!enlist (::)), result; raze typemap 17 18h; `int$]; + result:1 _ @[(::), result; 1+raze typemap 17 18h; `int$] + ] + ]; + result + ]; + // Nothing to do + result + ] + } +Rinstall:.r.install; +Rnew :.r.new; +Roff :.r.off; +Rset :.r.set; diff --git a/rinit.q b/rinit.q deleted file mode 100644 index 6bc02d7..0000000 --- a/rinit.q +++ /dev/null @@ -1,34 +0,0 @@ -/ R server for Q - -Rclose:`embedr 2:(`rclose;1) -Ropen:`embedr 2:(`ropen;1) -Rcmd0:`embedr 2:(`rcmd;1) -Rget0:`embedr 2:(`rget;1) -Rset0:`embedr 2:(`rset;2) -Rcmd:{Rcmd0 x} -Rget:{r:Rget0 x;Rconv r} -Rset:{Rset0[x;y]} - -Rconvmap:()!() -Rconvmap[enlist "Date"]:{-10957+`date$last x} -Rconvmap[enlist "POSIXt"]:{(-10957D)+`timestamp$1e9*last x} -Rconvmap[enlist "data.frame"]:{ - a:first x;if[0=count a`names;:last x]; - r:flip ((),`$a`names)!Rconv each last x; - r[`row.names]:$[null first rn:a`row.names;1+til last neg rn;rn]; - r} -Rconvmap[enlist "factor"]:{`$x[0;`levels] -1+last x} -Rconv:{ - if[(2<>count x) or 99<>type first x;:x]; // no attrs - c:first[x]`class; - if[10=type c;c:enlist c];c:c where 10h=type each c; - first[asc (),Rconvmap[c]] x - } -Rinstall:{[pkg] - pkg:$[-11=type pkg;string pkg;pkg];rcloud:"https://cloud.r-project.org"; - if[0i=first Rget"is.element('",pkg,"',installed.packages()[,1])"; - Rcmd"install.packages('",pkg,"',repos='",rcloud,"',dependencies = TRUE)"]; - } -Roff:{Rcmd "dev.off()"} -Rnew:{Rcmd "dev.new(noRStudioGD=TRUE)"} -setenv[`R_HOME;first @[system;@[.z.o like "w*";"call";"env"]," R RHOME";enlist""]] diff --git a/rtest.q b/rtest.q deleted file mode 100644 index 5481b21..0000000 --- a/rtest.q +++ /dev/null @@ -1,135 +0,0 @@ -/ test R server for Q -\l rinit.q - -Ropen 1 // set verbose mode - -Rcmd "a=array(1:24,c(2,3,4))" -Rget "dim(a)" -Rget "a" - -if[3<=.z.K;Rset["a";2?0Ng]] -Rget "a" - -Rcmd "b= 2 == array(1:24,c(2,3,4))" -Rget "dim(b)" -Rget "b" - -Rget "1.1*array(1:24,c(2,3,4))" - -Rset["xyz";1 2 3i] -Rget "xyz" - -Rget "pi" -Rget "2+3"; -Rget "11:11" -Rget "11:15" -a:Rget "matrix(1:6,2,3)" -a[1] -Rcmd "m=array(1:24,c(2,3,4))" -Rget "m" -Rget "length(m)" -Rget "dim(m)" -Rget "c(1,2,Inf,-Inf,NaN,NA)" - -Rcmd "pdf(tempfile(\"t1\",fileext=\".pdf\"))" -Rcmd "plot(c(2,3,5,7,11))" -Rcmd "dev.off()" - -Rcmd "x=factor(c('one','two','three','four'))" -Rget "x" -Rget "mode(x)" -Rget "typeof(x)" -Rget "c(TRUE,FALSE,NA,TRUE,TRUE,FALSE)" -Rcmd "foo <- function(x,y) {x + 2 * y}" -Rget "foo" -Rget "typeof(foo)" -Rget "foo (5,3)" - -Rget "wilcox.test(c(1,2,3),c(4,5,6))" -Rcmd "data(OrchardSprays)" -a:Rget "OrchardSprays" -a - -// to install package in non-interactive way -// install.packages("zoo", repos="http://cran.r-project.org") -Rget"install.packages" -//'Broken R object. -Rget".GlobalEnv" -//"environment" -Rget"emptyenv()" -//"environment" -Rget".Internal" -//"special" -@[Rcmd;"typeof(";like[;"incomplete: *"]] -@[Rcmd;"typeof()";like[;"eval error*"]] -Rget each ("cos";".C";"floor";"Im";"cumsum";"nargs";"proc.time";"dim";"length";"names";".External") -Rget "getGeneric('+')" -Rget"as.raw(10)" -Rget"as.logical(c(1,FALSE,NA))" -Rget"1:10" -// data.frame -Rget"data.frame(a=1:3, b=c('a','b','c'))" -Rget"data.frame(a=1:3, b=c('a','b','c'),stringsAsFactors=FALSE)" -Rget"data.frame(a=1:3)" -Rget"data.frame()" -// dates -Rget"as.Date('2005-12-31')" -Rget"as.Date(NA)" -Rget"rep(as.Date('2005-12-31'),2)" - - - -//lang -Rget "as.pairlist(1:10)" -Rget "as.pairlist(TRUE)" -Rget "as.pairlist(as.raw(1))" -Rget "pairlist('rnorm', 10L, 0.0, 2.0 )" -Rget "list(x ~ y + z)" -Rget "list( c(1, 5), c(2, 6), c(3, 7) )" -Rget "matrix( 1:16+.5, nc = 4 )" -Rget "Instrument <- setRefClass(Class='Instrument',fields=list('id'='character', 'description'='character'))" -Rget "Instrument$accessors(c('id', 'description'))" -Rget "Instrument$new(id='AAPL', description='Apple')" -Rget "(1+1i)" -Rget "(0:9)^2" -Rget"expression(rnorm, rnorm(10), mean(1:10))" -Rget"list( rep(NA_real_, 20L), rep(NA_real_, 6L) )" -Rget"c(1, 2, 1, 1, NA, NaN, -Inf, Inf)" - -// long vectors -Rcmd"x<-c(as.raw(1))" -//Rcmd"x[2147483648L]<-as.raw(1)" -count Rget`x - -.[Rset;("x[0]";1);"nyi"~] -Rget["c()"]~Rget"NULL" -()~Rget"c()" -{@[Rget;x;"type"~]}each (.z.p;0b;1;1f;{};([1 2 3]1 2 3)) -Rset[`x;1] -Rget each ("x";enlist "x";`x;`x`x) // ("x";"x")? -Rcmd"rm(x)" - -// run gc -Rget"gc()" - -Rset["a";`sym?`a`b`c] -`:x set string 10?`4 -Rset["a";get `:x] -hdel `:x; - -Rinstall`data.table -Rcmd"library(data.table)" -Rcmd"a<-data.frame(a=c(1,2))" -Rget`a -Rcmd "b<-data.table(a=c(1,2))" -Rget`b -Rcmd"inspect <- function(x, ...) .Internal(inspect(x,...))" -Rget`inspect -Rget"substitute(log(1))" - -flip[`a`b`row.names!(`1`2`1;`a`b`b;1 2 3)]~Rget"data.frame(a=as.factor(c(1,2,1)), b=c(\"a\",\"b\",\"b\"))" -flip[`a`b`row.names!(`1`2`1;("a";"b";"b");1 2 3)]~Rget"data.table(a=as.factor(c(1,2,1)), b=c(\"a\",\"b\",\"b\"))" -flip[`a`b`row.names!(`1`2`1;`10`20`30;1 2 3)]~Rget"data.table(a=as.factor(c(1,2,1)), b=as.factor(c(10,20,30)))" - - -// all {.[Rset;("x";0N!x);"main thread only"~]} peach 2#enlist ([]1 2) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt new file mode 100644 index 0000000..8270994 --- /dev/null +++ b/src/CMakeLists.txt @@ -0,0 +1,101 @@ +##%% Compilation %%##vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv/ + +# Default option is Release +if(NOT CMAKE_BUILD_TYPE) + set(CMAKE_BUILD_TYPE Release) +endif() + +# Download k.h +file(DOWNLOAD "https://github.com/KxSystems/kdb/raw/master/c/c/k.h" "${PROJECT_SOURCE_DIR}/include/k.h" ) + +# Specify target shared library name +add_library(${MY_LIBRARY_NAME} SHARED + common_R_interface/common.c + common_R_interface/q2r.c + common_R_interface/r2q.c + embedr_q2r.c + embedr_r2q.c + socketpair.c +) + +# Specify include directory +target_include_directories(${MY_LIBRARY_NAME} PRIVATE + ${PROJECT_SOURCE_DIR}/include + ${PROJECT_SOURCE_DIR}/include/common_R_interface + $ENV{R_INCLUDE_DIR} +) + +# Find dependency +find_library(R_LIBRARY + REQUIRED + NAMES libR R + HINTS $ENV{R_LIBRARY_DIR} +) + +if(MSVC) + # q library + file(DOWNLOAD "https://github.com/KxSystems/kdb/raw/master/w64/q.lib" "${CMAKE_BINARY_DIR}/q.lib" ) + set(Q_LIBRARY "${CMAKE_BINARY_DIR}/q.lib") +endif() + +# Compile option +target_compile_options(${MY_LIBRARY_NAME} PRIVATE + # kdb+ version + -DKXVER=3 + + # Compiler option + $<$:${CMAKE_C_FLAGS} /W3 /D WIN32_LEAN_AND_MEAN> + $<$>:${CMAKE_C_FLAGS} -fPIC -Wno-strict-aliasing> + + # Config option + $<$,$>>:-O3 -DNDEBUG> + $<$,$>>:-O0 -g> +) + +# Shared library prefix and suffix +# ex.) embedr.so for linux +# Suffix must be `.so` for Mac +if(APPLE) + set(CMAKE_SHARED_LIBRARY_SUFFIX ".so") +endif() + +set_target_properties(${MY_LIBRARY_NAME} PROPERTIES SUFFIX ${CMAKE_SHARED_LIBRARY_SUFFIX}) +set_target_properties(${MY_LIBRARY_NAME} PROPERTIES PREFIX "") + +# Link flag +if(APPLE) + set_target_properties(${MY_LIBRARY_NAME} PROPERTIES LINK_FLAGS "-undefined dynamic_lookup -mmacosx-version-min=10.12") +endif() + +# Link library +target_link_libraries(${MY_LIBRARY_NAME} PRIVATE + ${Q_LIBRARY} + ${R_LIBRARY} +) + +##%% Installation %%##vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv/ + +# OS Specific +if(APPLE) + set(OSFLAG m) +elseif(WIN32) + set(OSFLAG w) +else() + set(OSFLAG l) +endif() + +# Check 32bit or 64bit +set(BITNESS 32) +if(CMAKE_SIZEOF_VOID_P EQUAL 8) + set(BITNESS 64) +endif() + +# Copy built shared object after build instead of during installation +add_custom_command(TARGET ${MY_LIBRARY_NAME} + POST_BUILD + COMMAND ${CMAKE_COMMAND} -E copy "$" ${PROJECT_BINARY_DIR}/${CMAKE_PROJECT_NAME}/lib/${MY_LIBRARY_NAME}${CMAKE_SHARED_LIBRARY_SUFFIX} + DEPENDS ${MY_LIBRARY_NAME} +) + +# Install shared object at Release to QHOME and package directory +install(TARGETS ${MY_LIBRARY_NAME} DESTINATION $ENV{QHOME}/${OSFLAG}${BITNESS}/ CONFIGURATIONS Release) \ No newline at end of file diff --git a/src/common.c b/src/common.c deleted file mode 100644 index ee70ed6..0000000 --- a/src/common.c +++ /dev/null @@ -1,578 +0,0 @@ -/* - * common code for Q/R interface - */ - -int kx_connection=0; - -/* - * A (readable type name, R data type number) pair. - */ -struct data_types { - char *name; - Sint id; -}; - -/* - * A mapping from readable names to R data type numbers. - */ -const struct data_types r_data_types[] = { - {"unknown", -1}, - {"NULL", NILSXP}, - {"symbol", SYMSXP}, - {"pairlist", LISTSXP}, - {"closure", CLOSXP}, - {"environment", ENVSXP}, - {"promise", PROMSXP}, - {"language", LANGSXP}, - {"special", SPECIALSXP}, - {"builtin", BUILTINSXP}, - {"char", CHARSXP}, - {"logical", LGLSXP}, - {"integer", INTSXP}, - {"double", REALSXP}, - {"complex", CPLXSXP}, - {"character", STRSXP}, - {"...", DOTSXP}, - {"any", ANYSXP}, - {"expression", EXPRSXP}, - {"list", VECSXP}, - {"numeric", REALSXP}, - {"name", SYMSXP}, - {0, -1} -}; - -/* - * Brute force search of R type table. - * eg. get_type_name(LISTSXP) - */ -char* get_type_name(Sint type) -{ - int i; - for (i = 1; r_data_types[i].name != 0; i++) { - if (type == r_data_types[i].id) - return r_data_types[i].name; - } - return r_data_types[0].name; -} - -/* - * Given the appropriate names, types, and lengths, create an R named list. - */ -SEXP make_named_list(char **names, SEXPTYPE *types, Sint *lengths, Sint n) -{ - SEXP output, output_names, object = NULL_USER_OBJECT; - Sint elements; int i; - - PROTECT(output = NEW_LIST(n)); - PROTECT(output_names = NEW_CHARACTER(n)); - - for(i = 0; i < n; i++){ - elements = lengths[i]; - switch((int)types[i]) { - case LGLSXP: - PROTECT(object = NEW_LOGICAL(elements)); - break; - case INTSXP: - PROTECT(object = NEW_INTEGER(elements)); - break; - case REALSXP: - PROTECT(object = NEW_NUMERIC(elements)); - break; - case STRSXP: - PROTECT(object = NEW_CHARACTER(elements)); - break; - case VECSXP: - PROTECT(object = NEW_LIST(elements)); - break; - default: - error("Unsupported data type at %d %s\n", __LINE__, __FILE__); - } - SET_VECTOR_ELT(output, (Sint)i, object); - SET_STRING_ELT(output_names, i, COPY_TO_USER_STRING(names[i])); - } - SET_NAMES(output, output_names); - UNPROTECT(n+2); - return output; -} - -/* - * Make a data.frame from a named list by adding row.names, and class - * attribute. Uses "1", "2", .. as row.names. - */ -void make_data_frame(SEXP data) -{ - SEXP class_name, row_names; Sint n; - PROTECT(data); - PROTECT(class_name = NEW_CHARACTER((Sint) 1)); - SET_STRING_ELT(class_name, 0, COPY_TO_USER_STRING("data.frame")); - - /* Set the row.names. */ - n = GET_LENGTH(VECTOR_ELT(data,0)); - PROTECT(row_names=NEW_INTEGER(2)); INTEGER(row_names)[0]=NA_INTEGER; INTEGER(row_names)[1]=-n; - setAttrib(data, R_RowNamesSymbol, row_names); - SET_CLASS(data, class_name); - UNPROTECT(3); -} - -/* for datetime, timestamp */ -static void setdatetimeclass(SEXP sxp) -{ - SEXP datetimeclass = PROTECT(allocVector(STRSXP,2)); - SET_STRING_ELT(datetimeclass, 0, mkChar("POSIXt")); - SET_STRING_ELT(datetimeclass, 1, mkChar("POSIXct")); - setAttrib(sxp, R_ClassSymbol, datetimeclass); - UNPROTECT(2); -} - -/* - * We have functions that turn any K object into the appropriate R SEXP. - */ -static SEXP from_any_kobject(K object); -static SEXP error_broken_kobject(K); -static SEXP from_list_of_kobjects(K); -static SEXP from_bool_kobject(K); -static SEXP from_byte_kobject(K); -static SEXP from_guid_kobject(K); -static SEXP from_string_kobject(K); -static SEXP from_string_column_kobject(K); -static SEXP from_short_kobject(K); -static SEXP from_int_kobject(K); -static SEXP from_long_kobject(K); -static SEXP from_float_kobject(K); -static SEXP from_double_kobject(K); -static SEXP from_symbol_kobject(K); -static SEXP from_month_kobject(K); -static SEXP from_date_kobject(K); -static SEXP from_datetime_kobject(K); -static SEXP from_minute_kobject(K); -static SEXP from_second_kobject(K); -static SEXP from_time_kobject(K); -static SEXP from_timespan_kobject(K); -static SEXP from_timestamp_kobject(K); -static SEXP from_columns_kobject(K object); -static SEXP from_dictionary_kobject(K); -static SEXP from_table_kobject(K); - -/* - * An array of functions that deal with kdbplus data types. Note that the order - * is very important as we index it based on the kdb+ type number in the K object. - */ -typedef SEXP(*conversion_function)(K); - -conversion_function kdbplus_types[] = { - from_list_of_kobjects, - from_bool_kobject, - from_guid_kobject, - error_broken_kobject, - from_byte_kobject, - from_short_kobject, - from_int_kobject, - from_long_kobject, - from_float_kobject, - from_double_kobject, - from_string_kobject, - from_symbol_kobject, - from_timestamp_kobject, - from_month_kobject, - from_date_kobject, - from_datetime_kobject, - from_timespan_kobject, - from_minute_kobject, - from_second_kobject, - from_time_kobject -}; - -/* - * Convert K object to R object - */ -static SEXP from_any_kobject(K x) -{ - SEXP result; - int type = abs(x->t); - if (XT == type) - result = from_table_kobject(x); - else if (XD == type) - result = from_dictionary_kobject(x); - else if (105 == type || 101 == type) - result = from_int_kobject(ki(0)); - else if (type <= KT) - result = kdbplus_types[type](x); - else if (KT < type && type < 77) { - K t = k(0,"value",r1(x),(K)0); - if(t && t->t!=-128) { - result = from_any_kobject(t); - r0(t); - }else - result = error_broken_kobject(x); - } else if(77 <= type && type < XT){ - K t = k(0,"{(::) each x}",r1(x),(K)0); - if(t && t->t!=-128) { - result = from_any_kobject(t); - r0(t); - }else - result = error_broken_kobject(x); - } - else - result = error_broken_kobject(x); - return result; -} - -/* - * Convert K columns to R object - */ -static SEXP from_columns_kobject(K x) -{ - SEXP col, result; - int i, type, length = x->n; - K c; - PROTECT(result = NEW_LIST(length)); - for (i = 0; i < length; i++) { - c = xK[i]; - type = abs(c->t); - if (type == KC) - col = from_string_column_kobject(c); - else - col = from_any_kobject(c); - SET_VECTOR_ELT(result, i, col); - } - UNPROTECT(1); - return result; -} - -/* - * Complain that the given K object is not valid and return "unknown". - */ -static SEXP error_broken_kobject(K broken) -{ - error("Value is not a valid kdb+ object; unknown type %d\n", broken->t); - return mkChar(r_data_types[0].name); -} - -/* - * An R list from a K list object. - */ -static SEXP from_list_of_kobjects(K x) -{ - SEXP result; - int i, length = x->n; - PROTECT(result = NEW_LIST(length)); - for (i = 0; i < length; i++) { - SET_VECTOR_ELT(result, i, from_any_kobject(xK[i])); - } - UNPROTECT(1); - return result; -} - -/* - * These next functions have 2 main control flow paths. One for scalars and - * one for vectors. Because of the way the data is laid out in k objects, its - * not possible to combine them. - * - * We always decrement the reference count of the object as it will have been - * incremented in the initial dispatch. - * - * We promote shorts and floats to larger types when converting to R (ints and - * doubles respectively). - */ - -#define scalar(x) (x->t < 0) - -static SEXP from_bool_kobject(K x) -{ - SEXP result; - int length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_LOGICAL(1)); - LOGICAL_POINTER(result)[0] = x->g; - } - else { - int i; - PROTECT(result = NEW_LOGICAL(length)); - for(i = 0; i < length; i++) - LOGICAL_POINTER(result)[i] = kG(x)[i]; - } - UNPROTECT(1); - return result; -} - -static SEXP from_byte_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_INTEGER(1)); - INTEGER_POINTER(result)[0] = (int) x->g; - } - else { - PROTECT(result = NEW_INTEGER(length)); - for(i = 0; i < length; i++) - INTEGER_POINTER(result)[i] = kG(x)[i]; - } - UNPROTECT(1); - return result; -} - -static SEXP from_guid_kobject(K x) -{ - K y = k(kx_connection,"string",r1(x),(K)0); - SEXP r = from_any_kobject(y);r0(y); - return r; -} - -static SEXP from_short_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_INTEGER(1)); - INTEGER_POINTER(result)[0] = (int) x->h; - } - else { - PROTECT(result = NEW_INTEGER(xn)); - for(i = 0; i < length; i++) - INTEGER_POINTER(result)[i] = (int) xH[i]; - } - UNPROTECT(1); - return result; -} - -static SEXP from_int_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_INTEGER(1)); - INTEGER_POINTER(result)[0] = x->i; - } - else { - PROTECT(result = NEW_INTEGER(length)); - for(i = 0; i < length; i++) - INTEGER_POINTER(result)[i] = (int) xI[i]; - } - UNPROTECT(1); - return result; -} - -static SEXP from_long_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_NUMERIC(1)); - NUMERIC_POINTER(result)[0] = (double) x->j; - } - else { - PROTECT(result = NEW_NUMERIC(length)); - for(i = 0; i < length; i++) - NUMERIC_POINTER(result)[i] = (double) xJ[i]; - } - UNPROTECT(1); - return result; -} - -static SEXP from_float_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_NUMERIC(1)); - NUMERIC_POINTER(result)[0] = (double) x->e; - } - else { - PROTECT(result = NEW_NUMERIC(length)); - for(i = 0; i < length; i++) - NUMERIC_POINTER(result)[i] = (double) xE[i]; - } - UNPROTECT(1); - return result; -} - -static SEXP from_double_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_NUMERIC(1)); - NUMERIC_POINTER(result)[0] = x->f; - } - else { - PROTECT(result = NEW_NUMERIC(length)); - for(i = 0; i < length; i++) - NUMERIC_POINTER(result)[i] = xF[i]; - } - UNPROTECT(1); - return result; -} - -static SEXP from_string_kobject(K x) -{ - SEXP result; - int length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_CHARACTER(1)); - SET_STRING_ELT(result, 0, mkCharLen((S)&x->g,1)); - } - else { - PROTECT(result = allocVector(STRSXP, 1)); - SET_STRING_ELT(result, 0, mkCharLen((S)xG,length)); - }; - UNPROTECT(1); - return result; -} - -static SEXP from_string_column_kobject(K x) -{ - SEXP result; - int i, length = x->n; - PROTECT(result = NEW_CHARACTER(length)); - for(i = 0; i < length; i++) { - SET_STRING_ELT(result, i, mkCharLen((S)&kC(x)[i],1)); - } - UNPROTECT(1); - return result; -} - -static SEXP from_symbol_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_CHARACTER(1)); - SET_STRING_ELT(result, 0, mkChar(xs)); - } - else { - PROTECT(result = NEW_CHARACTER(length)); - for(i = 0; i < length; i++) - SET_STRING_ELT(result, i, mkChar((S)xS[i])); - } - UNPROTECT(1); - return result; -} - -static SEXP from_month_kobject(K object) -{ - return from_int_kobject(object); -} - -static SEXP from_date_kobject(K x) -{ - SEXP result; - SEXP dateclass; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_INTEGER(1)); - INTEGER_POINTER(result)[0] = x->i + 10957; - } - else { - PROTECT(result = NEW_INTEGER(length)); - for(i = 0; i < length; i++) - INTEGER_POINTER(result)[i] = (int) xI[i] + 10957; - } - dateclass = PROTECT(allocVector(STRSXP,1)); - SET_STRING_ELT(dateclass, 0, mkChar("Date")); - setAttrib(result, R_ClassSymbol, dateclass); - UNPROTECT(2); - return result; -} - -static SEXP from_datetime_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_NUMERIC(1)); - NUMERIC_POINTER(result)[0] = (x->f + 10957) * 86400; - } - else { - PROTECT(result = NEW_NUMERIC(length)); - for(i = 0; i < length; i++) - NUMERIC_POINTER(result)[i] = (kF(x)[i] + 10957) * 86400; - } - setdatetimeclass(result); - return result; -} - -static SEXP from_minute_kobject(K object) -{ - return from_int_kobject(object); -} - -static SEXP from_second_kobject(K object) -{ - return from_int_kobject(object); -} - -static SEXP from_time_kobject(K object) -{ - return from_int_kobject(object); -} - -static SEXP from_timespan_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_NUMERIC(1)); - NUMERIC_POINTER(result)[0] = x->j / 1e9; - } - else { - PROTECT(result = NEW_NUMERIC(length)); - for(i = 0; i < length; i++) - NUMERIC_POINTER(result)[i] = xJ[i] / 1e9; - } - UNPROTECT(1); - return result; -} - -static SEXP from_timestamp_kobject(K x) -{ - SEXP result; - int i, length = x->n; - if (scalar(x)) { - PROTECT(result = NEW_NUMERIC(1)); - NUMERIC_POINTER(result)[0] = 946684800 + x->j / 1e9; - } - else { - PROTECT(result = NEW_NUMERIC(length)); - for(i = 0; i < length; i++) - NUMERIC_POINTER(result)[i] = 946684800 + kJ(x)[i] / 1e9; - } - setdatetimeclass(result); - return result; -} - -static SEXP from_dictionary_kobject(K x) -{ - SEXP names, result; - K table; - - /* if keyed, try to create a simple table */ - /* ktd will free its argument if successful */ - /* if fails, x is still valid */ - if (XT==xx->t && XT==xy->t) { - r1(x); - if ((table = ktd(x))) { - result = from_table_kobject(table); - r0(table); - return result; - } - r0(x); - } - - PROTECT(names = from_any_kobject(xx)); - PROTECT(result = from_any_kobject(xy)); - SET_NAMES(result, names); - UNPROTECT(2); - return result; -} - -static SEXP from_table_kobject(K x) -{ - SEXP names, result; - PROTECT(names = from_any_kobject(kK(x->k)[0])); - PROTECT(result = from_columns_kobject(kK(x->k)[1])); - SET_NAMES(result, names); - UNPROTECT(2); - make_data_frame(result); - return result; -} diff --git a/src/common_R_interface/common.c b/src/common_R_interface/common.c new file mode 100644 index 0000000..2a73bcb --- /dev/null +++ b/src/common_R_interface/common.c @@ -0,0 +1,83 @@ +/** + * Common source for R integration with kdb+. Define global variables. + */ + +/*-----------------------------------------------*/ +/* Load Libraries */ +/*-----------------------------------------------*/ + +#include "common.h" + +/*-----------------------------------------------*/ +/* Global Variable */ +/*-----------------------------------------------*/ + +// Offsets used in conversion between R and q +const J epoch_offset=10957*24*60*60*1000000000LL; +// Seconds in a day +const int sec2day = 86400; +// Days between 1970.01.01 & 2000.01.01 +const int kdbDateOffset = 10957; +// Seconds between 1970.01.01 & 2000.01.01 +const int kdbSecOffset = 946684800; + +SEXP R_UnitsSymbol=NULL; +SEXP R_TzSymbol=NULL; + +/*-----------------------------------------------*/ +/* Utility Functions */ +/*-----------------------------------------------*/ + +/** + * @brief Check if it is a leap year. + */ +bool is_leap(const int year){ + return (year % 4 == 0 && year % 100 != 0) || (year % 400 == 0); +} + +/** + * @brief Functions to derive day count since kdb+ epoch from month count + */ +int months2days(const int monthcount){ + int days=0; + const int mdays[12]={31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}; + const int years = monthcount / 12; + for(int i= 0; i < years; i++) + days+=is_leap(2000+i)?366:365; + const int this_year = 2000+years; + const int months= monthcount % 12; + for(int i=0; i < months; i++){ + if(i == 1) + days+=is_leap(this_year)?29:28; + else + days+=mdays[i]; + } + return days; +} + +/** + * @brief Functions to derive month count since kdb epoch from day count + */ +int days2months(const int daycount){ + int year=2000, months=0, days=0; + const int mdays[12]={31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}; + while(true){ + if(daycount < days+(is_leap(year)?366:365)) + break; + days+=is_leap(year)?366:365; + months+=12; + year++; + } + for(int i= 0; i < 12; i++){ + if(days < daycount){ + if(i==1) + days+=is_leap(year)?29:28; + else + days+=mdays[i]; + months+=1; + } + else + break; + } + return months; +} diff --git a/src/common_R_interface/q2r.c b/src/common_R_interface/q2r.c new file mode 100644 index 0000000..2f1d43b --- /dev/null +++ b/src/common_R_interface/q2r.c @@ -0,0 +1,591 @@ +/*-----------------------------------------------*/ +/* File: q2r.c */ +/* Overview: Common code for Q -> R interface */ +/*-----------------------------------------------*/ + +/* + * The public interface used from Q. + * https://cran.r-project.org/doc/manuals/r-release/R-ints.pdf + * https://cran.r-project.org/doc/manuals/r-release/R-exts.html + */ + +/*-----------------------------------------------*/ +/* Load Libraries */ +/*-----------------------------------------------*/ + +#include "common.h" + +/*-----------------------------------------------*/ +/* Global Variable */ +/*-----------------------------------------------*/ + +int kx_connection=0; + +/*-----------------------------------------------*/ +/* Structs */ +/*-----------------------------------------------*/ + +/* + * A (readable type name, R data type number) pair. + */ +struct data_types { + char *name; + Sint id; +}; + +/* + * A mapping from readable names to R data type numbers. + */ +const struct data_types r_data_types[] = { + {"unknown", -1}, + {"NULL", NILSXP}, + {"symbol", SYMSXP}, + {"pairlist", LISTSXP}, + {"closure", CLOSXP}, + {"environment", ENVSXP}, + {"promise", PROMSXP}, + {"language", LANGSXP}, + {"special", SPECIALSXP}, + {"builtin", BUILTINSXP}, + {"char", CHARSXP}, + {"logical", LGLSXP}, + {"integer", INTSXP}, + {"double", REALSXP}, + {"complex", CPLXSXP}, + {"character", STRSXP}, + {"...", DOTSXP}, + {"any", ANYSXP}, + {"expression", EXPRSXP}, + {"list", VECSXP}, + {"numeric", REALSXP}, + {"name", SYMSXP}, + {0, -1} +}; + +/*-----------------------------------------------*/ +/* Predefinition of Functions */ +/*-----------------------------------------------*/ + +/** + *@brief Function used in the conversion of kdb guid to R char array + */ +static K guid_2_char(K x); + +/* + * We have functions that turn any K object into the appropriate R SEXP. + */ +SEXP from_any_kobject(K x); +static SEXP from_bool_kobject(K); +static SEXP from_byte_kobject(K); +static SEXP from_guid_kobject(K); +static SEXP from_string_column_kobject(K); +static SEXP from_short_kobject(K); +static SEXP from_int_kobject(K); +static SEXP from_long_kobject(K); +static SEXP from_real_kobject(K); +static SEXP from_float_kobject(K); +SEXP from_string_kobject(K); +SEXP from_symbol_kobject(K); +static SEXP from_timestamp_kobject(K); +static SEXP from_month_kobject(K); +static SEXP from_date_kobject(K); +static SEXP from_datetime_kobject(K); +static SEXP from_timespan_kobject(K); +static SEXP from_minute_kobject(K); +static SEXP from_second_kobject(K); +static SEXP from_time_kobject(K); +static SEXP from_columns_kobject(K); +static SEXP from_table_kobject(K); +static SEXP from_dictionary_kobject(K); +static SEXP from_columns_kobject(K x); +static SEXP error_broken_kobject(K broken); +static SEXP from_list_of_kobjects(K x); + +/* + * An array of functions that deal with kdbplus data types. Note that the order + * is very important as we index it based on the kdb+ type number in the K object. + */ +typedef SEXP(*conversion_function)(K); + +conversion_function kdbplus_types[] = { + from_list_of_kobjects, from_bool_kobject, from_guid_kobject, + error_broken_kobject, from_byte_kobject, from_short_kobject, + from_int_kobject, from_long_kobject, from_real_kobject, + from_float_kobject, from_string_kobject, from_symbol_kobject, + from_timestamp_kobject, from_month_kobject, from_date_kobject, + from_datetime_kobject, from_timespan_kobject, from_minute_kobject, + from_second_kobject, from_time_kobject +}; + +/*-----------------------------------------------*/ +/* Functions */ +/*-----------------------------------------------*/ + +/* + * Brute force search of R type table. + * eg. get_type_name(LISTSXP) + */ +char* get_type_name(Sint type) { + for (int i = 1; r_data_types[i].name != 0; i++){ + if(type == r_data_types[i].id) + return r_data_types[i].name; + } + return r_data_types[0].name; +} + +/** + *@brief Make a data.frame from a named list by adding row.names, and class + * attribute. Uses "1", "2", .. as row.names. + */ +void make_data_frame(SEXP data) { + SEXP row_names; + /* Set the row.names. */ + J n= XLENGTH(VECTOR_ELT(data, 0)); + PROTECT(row_names= allocVector(INTSXP,2)); + INTEGER(row_names)[0]= NA_INTEGER; + INTEGER(row_names)[1]= -n; + setAttrib(data, R_RowNamesSymbol, row_names); + classgets(data, PROTECT(mkString("data.frame"))); + UNPROTECT(2); +} + +/* for datetime */ +static SEXP setdatetimeclass(SEXP sxp) { + SEXP datetimeclass = PROTECT(allocVector(STRSXP,2)); + SET_STRING_ELT(datetimeclass, 0, mkChar("POSIXct")); + SET_STRING_ELT(datetimeclass, 1, mkChar("POSIXt")); + classgets(sxp, datetimeclass); + UNPROTECT(1); + return sxp; +} + +/* for timestamp */ +static SEXP settimestampclass(SEXP sxp) { + SEXP classValue; + SEXP tag = PROTECT(mkString(".S3Class")); + SEXP val = PROTECT(mkString("integer64")); + setAttrib(sxp, tag, val); + UNPROTECT(2); + classValue= PROTECT(mkString("nanotime")); + tag = PROTECT(mkString("package")); + val = PROTECT(mkString("nanotime")); + setAttrib(classValue, tag, val); + classgets(sxp, classValue); + UNPROTECT(3); + return asS4(sxp,TRUE,0); +} + +/* for timespan, minute, second */ +//Available units: "secs", "mins", "hours", "days", "weeks" +static SEXP setdifftimeclass(SEXP sxp, char* units) { + SEXP difftimeclass= PROTECT(allocVector(STRSXP, 1)); + SET_STRING_ELT(difftimeclass, 0, mkChar("difftime")); + classgets(sxp, difftimeclass); + if (R_UnitsSymbol == NULL) + R_UnitsSymbol = install("units"); + SEXP difftimeunits= PROTECT(allocVector(STRSXP, 1)); + SET_STRING_ELT(difftimeunits, 0, mkChar(units)); + setAttrib(sxp, R_UnitsSymbol, difftimeunits); + UNPROTECT(2); + return sxp; +} + +/* for setting timezone */ +static SEXP settimezone(SEXP sxp, char* tzone) { + SEXP timezone= PROTECT(allocVector(STRSXP, 1)); + SET_STRING_ELT(timezone, 0, mkChar(tzone)); + if (R_TzSymbol == NULL) + R_TzSymbol = install("tzone"); + setAttrib(sxp, R_TzSymbol, timezone); + UNPROTECT(1); + return sxp; +} + +/* for date */ +static SEXP setdateclass(SEXP sxp) { + SEXP timeclass= PROTECT(allocVector(STRSXP, 1)); + SET_STRING_ELT(timeclass, 0, mkChar("Date")); + classgets(sxp, timeclass); + UNPROTECT(1); + return sxp; +} + +/* month */ +static SEXP setmonthclass(SEXP sxp){ + SEXP timeclass= PROTECT(allocVector(STRSXP, 2)); + SET_STRING_ELT(timeclass, 0, mkChar("Date")); + SET_STRING_ELT(timeclass, 1, mkChar("month")); + classgets(sxp, timeclass); + UNPROTECT(1); + return sxp; +} + +/* for timespan */ +static SEXP settimespanclass(SEXP sxp) { + SEXP timeclass= PROTECT(allocVector(STRSXP, 2)); + SET_STRING_ELT(timeclass, 0, mkChar("integer64")); + SET_STRING_ELT(timeclass, 1, mkChar("timespan")); + classgets(sxp, timeclass); + UNPROTECT(1); + return sxp; +} + +/* + * Convert K object to R object + */ +SEXP from_any_kobject(K x) { + SEXP result; + int type = abs(x->t); + if (XT == type) + result = from_table_kobject(x); + else if (XD == type) + result = from_dictionary_kobject(x); + else if(101 == type) + result= R_NilValue; + else if(105 == type) + result= from_int_kobject(ki(0)); + else if (type <= KT) + result = kdbplus_types[type](x); + else if (KT < type && type < 77){ + K t = k(0,"value",r1(x),(K)0); + if(t && t->t!=-128) { + result = from_any_kobject(t); + r0(t); + } + else + result = error_broken_kobject(x); + } + else if(77 <= type && type < XT){ + K t = k(0,"{(::) each x}",r1(x),(K)0); + if(t && t->t!=-128) { + result = from_any_kobject(t); + r0(t); + } + else + result = error_broken_kobject(x); + } + else + result = error_broken_kobject(x); + return result; +} + +/* + * Convert K columns to R object + */ +static SEXP from_columns_kobject(K x) { + SEXP col, result; + J i, type, length= x->n; + K c; + PROTECT(result= allocVector(VECSXP,length)); + for(i= 0; i < length; i++) { + c= kK(x)[i]; + type= abs(c->t); + if(type == KC) + col= from_string_column_kobject(c); + else + col= from_any_kobject(c); + SET_VECTOR_ELT(result, i, col); + } + UNPROTECT(1); + return result; +} + +/* + * Complain that the given K object is not valid and return "unknown". + */ +static SEXP error_broken_kobject(K broken) { + error("Value is not a valid kdb+ object; unknown type %d\n", broken->t); + return mkChar(r_data_types[0].name); +} + +/* + * An R list from a K list object. + */ +static SEXP from_list_of_kobjects(K x) { + SEXP result; + K y; + J i, length= x->n, utype; + PROTECT(result= allocVector(VECSXP,length)); + utype= length > 0 ? kK(x)[0]->t : 0; + for(i= 0; i < length; i++) { + y= kK(x)[i]; + utype= utype == y->t ? utype : 0; + SET_VECTOR_ELT(result, i, from_any_kobject(y)); + } + if(utype == KC) + result= coerceVector(result, STRSXP); + UNPROTECT(1); + return result; +} + +/* + * These next functions have 2 main control flow paths. One for scalars and + * one for vectors. Because of the way the data is laid out in k objects, its + * not possible to combine them. + * + * We always decrement the reference count of the object as it will have been + * incremented in the initial dispatch. + * + * We promote shorts and floats to larger types when converting to R (ints and + * doubles respectively). + */ + +static I scalar(K x) { return x->t < 0; } + +static SEXP from_bool_kobject(K x) { + SEXP result; + if(scalar(x)) return ScalarLogical(x->g); + PROTECT(result= allocVector(LGLSXP,x->n)); + for(int i= 0; i < x->n; i++) + LOGICAL(result)[i]= kG(x)[i]; + UNPROTECT(1); + return result; +} + +static SEXP from_byte_kobject(K x) { + SEXP result;G*r; + if(scalar(x)) return ScalarRaw(x->g); + PROTECT(result= allocVector(RAWSXP,x->n)); + r=RAW(result); + for(int i= 0; i < x->n; i++) + r[i]= kG(x)[i]; + UNPROTECT(1); + return result; +} + +static SEXP from_guid_kobject(K x){ + SEXP r;K y,z= ktn(0,x->n); + if(scalar(x)){ + y= guid_2_char(kG(x)); + r= from_any_kobject(y); + r0(y); + return r; + } + for(J i=0;in;i++){ + y= guid_2_char((G*)(&kU(x)[i])); + kK(z)[i]= kp(kC(y)); + r0(y); + } + r = from_any_kobject(z); + r0(z); + return r; +} + +static SEXP from_short_kobject(K x) { + SEXP result; + if(scalar(x)) return ScalarInteger(x->h==nh?NA_INTEGER:(int)x->h); + PROTECT(result= allocVector(INTSXP,x->n)); + for(int i= 0; i < x->n; i++) + INTEGER(result)[i]= kH(x)[i]==nh?NA_INTEGER:kH(x)[i]; + UNPROTECT(1); + return result; +} + +static SEXP from_int_kobject(K x) { + SEXP result; + if(scalar(x)) return ScalarInteger(x->i); + PROTECT(result= allocVector(INTSXP,x->n)); + for(int i= 0; i < x->n; i++) + INTEGER(result)[i]= kI(x)[i]; + UNPROTECT(1); + return result; +} + +static SEXP from_long_kobject(K x) { + SEXP result; + long n=scalar(x)?1:x->n; + PROTECT(result= allocVector(REALSXP,n)); + if(scalar(x)) + INT64(result)[0]= x->j; + else { + for(int i= 0; i < n; i++) + INT64(result)[i]= kJ(x)[i]; + } + classgets(result, mkString("integer64")); + UNPROTECT(1); + return result; +} + +static SEXP from_real_kobject(K x) { + SEXP result; + if(scalar(x)) return ScalarReal(ISNAN(x->e)?R_NaN:x->e); + PROTECT(result= allocVector(REALSXP,x->n)); + for(int i= 0; i < x->n; i++) + REAL(result)[i]= (double) ISNAN(kE(x)[i])?R_NaN:kE(x)[i]; + UNPROTECT(1); + return result; +} + +static SEXP from_float_kobject(K x) { + SEXP result; + if(scalar(x)) return ScalarReal(ISNAN(x->f)?R_NaN:x->f); + PROTECT(result= allocVector(REALSXP,x->n)); + for(int i= 0; i < x->n; i++) + REAL(result)[i]= ISNAN(kF(x)[i])?R_NaN:kF(x)[i]; + UNPROTECT(1); + return result; +} + +SEXP from_string_kobject(K x) { + SEXP result; + long n=scalar(x)?1:x->n; + PROTECT(result= allocVector(STRSXP,1)); + if(scalar(x)) + SET_STRING_ELT(result, 0, mkCharLen((S) &x->g, 1)); + else + SET_STRING_ELT(result, 0, mkCharLen((S) kC(x), n)); + UNPROTECT(1); + return result; +} + +static SEXP from_string_column_kobject(K x) { + SEXP result; + long n=scalar(x)?1:x->n; + PROTECT(result= allocVector(STRSXP,n)); + for(int i = 0; i < n; i++) + SET_STRING_ELT(result, i, mkCharLen((S)&kC(x)[i],1)); + UNPROTECT(1); + return result; +} + +SEXP from_symbol_kobject(K x) { + SEXP result; + if(scalar(x)) return mkString(x->s); + PROTECT(result= allocVector(STRSXP,x->n)); + for(int i= 0; i < x->n; i++) + SET_STRING_ELT(result, i, mkChar(kS(x)[i])); + UNPROTECT(1); + return result; +} + +static SEXP from_timestamp_kobject(K x) { + SEXP result=from_long_kobject(x); + long n=XLENGTH(result); + PROTECT(result); + for(int i= 0; i < n; i++) + if(INT64(result)[i]!=nj)INT64(result)[i]+=epoch_offset; + settimestampclass(result); + UNPROTECT(1); + return result; +} + +static SEXP from_month_kobject(K x) { + SEXP result=PROTECT(from_int_kobject(x)); + for(J i= 0; i < XLENGTH(result); i++) + if(INTEGER(result)[i]!=NA_INTEGER) + INTEGER(result)[i]=months2days(INTEGER(result)[i])+kdbDateOffset; + setmonthclass(result); + UNPROTECT(1); + return result; +} + +static SEXP from_date_kobject(K x) { + SEXP result=PROTECT(from_int_kobject(x)); + for(int i= 0; i < XLENGTH(result); i++) + if(INTEGER(result)[i]!=NA_INTEGER) + INTEGER(result)[i]+=kdbDateOffset; + setdateclass(result); + UNPROTECT(1); + return result; +} + +static SEXP from_datetime_kobject(K x) { + SEXP result=PROTECT(from_float_kobject(x)); + for(int i= 0; i < XLENGTH(result); i++) + REAL(result)[i]= REAL(result)[i]* sec2day + kdbDateOffset * sec2day; + setdatetimeclass(result); + settimezone(result,"GMT"); + UNPROTECT(1); + return result; +} + +static SEXP from_timespan_kobject(K x) { + SEXP result=from_long_kobject(x); + J i,n=XLENGTH(result); + PROTECT(result); + + //judge timespan or days + int isDay=1; + const int examine=n<5?n:5; + for(int j= 0; j < examine; j++) + isDay= (((INT64(result)[j] % (sec2day*1000000000LL))==0) < isDay)?0:isDay; + + if(isDay){ + //difftime days + SEXP realresult; + PROTECT(realresult=allocVector(REALSXP, n)); + for(i= 0; i < n; i++) + REAL(realresult)[i]=(INT64(result)[i]!=nj)?((INT64(result)[i]/1000000000LL)/sec2day):NA_REAL; + setdifftimeclass(realresult,"days"); + UNPROTECT(2); + return realresult; + } + else{ + //timespan + settimespanclass(result); + UNPROTECT(1); + return result; + } +} + +static SEXP from_minute_kobject(K x) { + SEXP result=PROTECT(from_int_kobject(x)); + setdifftimeclass(result,"mins"); + UNPROTECT(1); + return result; +} + +static SEXP from_second_kobject(K x) { + SEXP result=PROTECT(from_int_kobject(x)); + setdifftimeclass(result,"secs"); + UNPROTECT(1); + return result; +} + +static SEXP from_time_kobject(K x) { + return from_int_kobject(x); +} + +static SEXP from_table_kobject(K x) { + SEXP names, result; + PROTECT(names = from_any_kobject(kK(x->k)[0])); + PROTECT(result = from_columns_kobject(kK(x->k)[1])); + setAttrib(result, R_NamesSymbol, names); + UNPROTECT(2); + make_data_frame(result); + return result; +} + +static SEXP from_dictionary_kobject(K x) { + SEXP names, result; + K table, k= kK(x)[0], v= kK(x)[1]; + /* if keyed, try to create a simple table */ + /* ktd will free its argument if successful */ + /* if fails, x is still valid */ + if (XT==k->t && XT==v->t) { + r1(x); + if ((table = ktd(x))) { + result = from_table_kobject(table); + r0(table); + return result; + } + r0(x); + } + PROTECT(names = from_any_kobject(k)); + PROTECT(result = from_any_kobject(v)); + setAttrib(result, R_NamesSymbol, names); + UNPROTECT(2); + return result; +} + +/* + * Util function + */ + +static K guid_2_char(K x){ + K y= ktn(KC,37); + G*gv= x; + sprintf(kC(y),"%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x",gv[ 0],gv[ 1],gv[ 2],gv[ 3],gv[ 4],gv[ 5],gv[ 6],gv[ 7],gv[ 8],gv[ 9],gv[10],gv[11],gv[12],gv[13],gv[14],gv[15]); + y->n= 36; + return(y); +} diff --git a/src/common_R_interface/r2q.c b/src/common_R_interface/r2q.c new file mode 100644 index 0000000..d681148 --- /dev/null +++ b/src/common_R_interface/r2q.c @@ -0,0 +1,641 @@ +/*-----------------------------------------------*/ +/* File: r2q.c */ +/* Overview: common code for R -> Q interface */ +/*-----------------------------------------------*/ + +/* + * The public interface used from Q. + * https://cran.r-project.org/doc/manuals/r-release/R-ints.pdf + * https://cran.r-project.org/doc/manuals/r-release/R-exts.html + */ + +/*-----------------------------------------------*/ +/* Load Libraries */ +/*-----------------------------------------------*/ + +#include "common.h" + +/*-----------------------------------------------*/ +/* Predefinition of Functions */ +/*-----------------------------------------------*/ + +/* + * Conversion utility. + */ +static K klogicv(J len, int *val); +static K klogica(J len, int rank, int *shape, int *val); +static K kintv(J len, int *val); +static K kinta(J len, int rank, int *shape, int *val); +static K klonga(J len, int rank, int *shape, J*val); +static K kdoublev(J len, double *val); +static K kdoublea(J len, int rank, int *shape, double *val); + +/* + * convert R SEXP into K object. + */ +static K error_broken_robject(SEXP); +static K from_logical_robject(SEXP); +static K from_integer_robject(SEXP); +static K from_double_robject(SEXP); +static K from_char_robject(SEXP); +static K from_symbol_robject(SEXP); +static K from_date_robject(SEXP); +static K from_datetime_robject(SEXP); +static K from_difftime_robject(SEXP); +static K from_null_robject(SEXP); +static K from_character_robject(SEXP); +static K from_vector_robject(SEXP); +static K from_raw_robject(SEXP); +static K from_nyi_robject(SEXP); +static K from_frame_robject(SEXP); +static K from_factor_robject(SEXP); +static K from_closure_robject(SEXP); +static K from_language_robject(SEXP); + +/*-----------------------------------------------*/ +/* Functions */ +/*-----------------------------------------------*/ + +/* + * Utility functions to identify class and unit + */ + +Rboolean isClass(const char *class_, SEXP s) { + SEXP klass; + int i; + if(OBJECT(s)) { + klass= getAttrib(s, R_ClassSymbol); + for(i= 0; i < length(klass); i++) + if(!strcmp(CHAR(STRING_ELT(klass, i)), class_)) + return TRUE; + } + return FALSE; +} + +Rboolean isUnit(const char *units_, SEXP s){ + SEXP unit; + unit=getAttrib(s, R_UnitsSymbol); + if(!strcmp(CHAR(asChar(unit)), units_)) + return TRUE; + return FALSE; +} + +/* + * Utility functions to handle attribute + */ + +/** + * @brief add attribute + **/ +static K addattR (K x,SEXP att) { + // attrs are pairlists: LISTSXP + K u = from_pairlist_robject(att); + return knk(2,u,x); +} + +/** + * @brief add attribute if any + **/ +K attR(K x,SEXP sxp) { + SEXP att = ATTRIB(sxp); + if (isNull(att)) + return x; + return addattR(x,att); +} + +/** + * @brief Build atom value dictionary. + */ +static K atom_value_dict(J len, K v, SEXP keys){ + K k= ktn(KS, len); + for(J i= 0; i < len; i++) { + const char *keyName= CHAR(STRING_ELT(keys, i)); + kS(k)[i]= ss((S) keyName); + } + return xD(k,v); +} + +/* + * Conversion from R to Q + */ + +K from_any_robject(SEXP sxp){ + if(isClass("data.frame", sxp)) + return from_frame_robject(sxp); + if(isClass("factor", sxp)) + return from_factor_robject(sxp); + if(isClass("Date", sxp)) + return from_date_robject(sxp); + if(isClass("POSIXt", sxp)) + return from_datetime_robject(sxp); + if(isClass("difftime", sxp)) + return from_difftime_robject(sxp); + K result = 0; + int type = TYPEOF(sxp); + switch (type) { + case NILSXP : + return from_null_robject(sxp); + break; /* nil = NULL */ + case SYMSXP : + return from_symbol_robject(sxp); + break; /* symbols */ + case LISTSXP : + return from_pairlist_robject(sxp); + break; /* lists of dotted pairs */ + case CLOSXP : + return from_closure_robject(sxp); + break; /* closures */ + case LANGSXP : + return from_language_robject(sxp); + break; /* language constructs (special lists) */ + case CHARSXP : + return from_char_robject(sxp); + break; /* "scalar" string type (internal only)*/ + case LGLSXP : + return from_logical_robject(sxp); + break; /* logical vectors */ + case RAWSXP : + return from_raw_robject(sxp); + break; /* raw bytes */ + case INTSXP : + return from_integer_robject(sxp); + break; /* integer vectors */ + case REALSXP : + return from_double_robject(sxp); + break; /* real variables */ + case STRSXP : + return from_character_robject(sxp); + break; /* string vectors */ + case VECSXP : + return from_vector_robject(sxp); + break; /* generic vectors */ + case FREESXP : + return error_broken_robject(sxp); + break; /* node released by GC */ + case ANYSXP : + return error_broken_robject(sxp); + break; /* make "any" args work */ + case EXPRSXP : + case BCODESXP : + case EXTPTRSXP : + case WEAKREFSXP : + case S4SXP : + case NEWSXP : + case FUNSXP : + case PROMSXP : + case SPECIALSXP : + case BUILTINSXP : + case ENVSXP : + case CPLXSXP : + case DOTSXP : + return from_nyi_robject(sxp); + break; + } + return result; +} + +static K error_broken_robject(SEXP sxp) { + return krr("Broken R object."); +} + +static K from_nyi_robject(SEXP sxp){ + return attR(kp((S)Rf_type2char(TYPEOF(sxp))),sxp); +} + +static K from_frame_robject(SEXP sxp) { + J length= XLENGTH(sxp); + if(length == 0) + return from_null_robject(sxp); + SEXP colNames= getAttrib(sxp, R_NamesSymbol); + K k= ktn(KS, length), v= ktn(0, length); + for(J i= 0; i < length; i++) { + kK(v)[i]= from_any_robject(VECTOR_ELT(sxp, i)); + const char *colName= CHAR(STRING_ELT(colNames, i)); + kS(k)[i]= ss((S) colName); + } + K tbl= xT(xD(k, v)); + return tbl; +} + +static K from_factor_robject(SEXP sxp) { + J length= XLENGTH(sxp); + SEXP levels= asCharacterFactor(sxp); + K x= ktn(KS, length); + for(J i= 0; i < length; i++) { + const char *sym= CHAR(STRING_ELT(levels, i)); + kS(x)[i]= ss((S) sym); + } + return x; +} + +static K from_raw_robject(SEXP sxp) { + K x = ktn(KG,XLENGTH(sxp)); + DO(xn,kG(x)[i]=RAW(sxp)[i]) + return x; +} + + +static K from_date_robject(SEXP sxp) { + K x; + J length= XLENGTH(sxp); + x= ktn(isClass("month", sxp)?KM:KD,length); + int type= TYPEOF(sxp); + switch(type) { + case INTSXP: + if(isClass("month", sxp)){ + DO(length,kI(x)[i]=days2months(INTEGER(sxp)[i]-kdbDateOffset)); + } + else{ + DO(length,kI(x)[i]=INTEGER(sxp)[i]-kdbDateOffset); + } + break; + default: + if(isClass("month", sxp)){ + DO(length,kI(x)[i]=ISNA(REAL(sxp)[i])?NA_INTEGER:days2months((I)REAL(sxp)[i]-kdbDateOffset)); + } + else{ + DO(length,kI(x)[i]=ISNA(REAL(sxp)[i])?NA_INTEGER:(I)REAL(sxp)[i]-kdbDateOffset); + } + } + return x; +} + +static K from_datetime_ct_robject(SEXP sxp) { + K x; + J length = XLENGTH(sxp); + x = ktn(KZ,length); + DO(length,kF(x)[i]=(F)(((REAL(sxp)[i]-kdbSecOffset)/sec2day))); + return x; +} + +static K from_datetime_lt_robject(SEXP sxp) { + K x; + J i, key_length= XLENGTH(sxp); + x= ktn(0, key_length); + for(i= 0; i < key_length; ++i) + kK(x)[i]= from_any_robject(VECTOR_ELT(sxp, i)); + J element_length=kK(x)[0]->n; + K res=ktn(KZ, element_length); + for(i=0; i < element_length; i++){ + //Relying on the order of tm key + struct tm dttm; + dttm.tm_sec =kF(kK(x)[0])[i]; + dttm.tm_min =kI(kK(x)[1])[i]; + dttm.tm_hour =kI(kK(x)[2])[i]; + dttm.tm_mday =kI(kK(x)[3])[i]; + dttm.tm_mon =kI(kK(x)[4])[i]; + dttm.tm_year =kI(kK(x)[5])[i]; + dttm.tm_wday =kI(kK(x)[6])[i]; + dttm.tm_yday =kI(kK(x)[7])[i]; + dttm.tm_isdst=kI(kK(x)[8])[i]; + kF(res)[i]=(((F)mktime(&dttm)-kdbSecOffset)/sec2day); + } + return res; +} + +//Wraper function of POSIXt +static K from_datetime_robject(SEXP sxp) { + if(isClass("POSIXct", sxp)) + return from_datetime_ct_robject(sxp); + else + return from_datetime_lt_robject(sxp); +} + +static K from_second_or_minute_robject(SEXP sxp){ + K x; + J length=XLENGTH(sxp); + x=ktn(isUnit("secs", sxp)?KV:KU, length); + int type=TYPEOF(sxp); + switch(type){ + case INTSXP: + DO(length, kI(x)[i]=INTEGER(sxp)[i]); + break; + default: + DO(length,kI(x)[i]=ISNA(REAL(sxp)[i])?NA_INTEGER:(I) REAL(sxp)[i]); + } + return x; +} + +static K from_days_robject(SEXP sxp){ + K x; + J length= XLENGTH(sxp); + x= ktn(KN,length); + DO(length,kJ(x)[i]=(J) (REAL(sxp)[i]*sec2day)*1000000000LL) + return x; +} + +/* Wrapper function of difftime */ +static K from_difftime_robject(SEXP sxp){ + if(isUnit("secs", sxp) || isUnit("mins", sxp)){ + // secs or mins + return from_second_or_minute_robject(sxp); + } + else if(isUnit("days", sxp)){ + // days + return from_days_robject(sxp); + } + else{ + // hours + return from_nyi_robject(sxp); + } +} + +/* + * NULL in R(R_NilValue): often used as generic zero length vector + * NULL objects cannot have attributes and attempting to assign one by attr gives an error + */ +static K from_null_robject(SEXP sxp) { + return knk(0); +} + +static K from_symbol_robject(SEXP sxp) { + const char* t = CHAR(PRINTNAME(sxp)); + K x = ks((S)t); + return attR(x,sxp); +} + +static K from_closure_robject(SEXP sxp) { + K x = from_any_robject(FORMALS(sxp)); + K y = from_any_robject(BODY(sxp)); + return attR(knk(2,x,y),sxp); +} + +static K from_language_robject(SEXP sxp) { + K x = knk(0); + SEXP s = sxp; + while (0 < length(s)) { + x = jk(&x,from_any_robject(CAR(s))); + s = CDR(s); + } + return attR(x,sxp); +} + +static K from_char_robject(SEXP sxp) { + K x = kpn((S)CHAR(STRING_ELT(sxp,0)),LENGTH(sxp)); + return attR(x,sxp); +} + +static K from_logical_robject(SEXP sxp) { + K x; + J len = XLENGTH(sxp); + SEXP dim= getAttrib(sxp, R_DimSymbol); + if (isNull(dim)) { + //Process values + x = klogicv(len,LOGICAL(sxp)); + //Dictionary with atom values + SEXP keyNames= getAttrib(sxp, R_NamesSymbol); + if(!isNull(keyNames)&&len==XLENGTH(keyNames)) + return atom_value_dict(len, x, keyNames); + //Normal kdb+ list + return attR(x,sxp); + } + x = klogica(len,length(dim),INTEGER(dim),LOGICAL(sxp)); + SEXP dimnames= getAttrib(sxp, R_DimNamesSymbol); + if (!isNull(dimnames)) + return attR(x,sxp); + SEXP e; + PROTECT(e = duplicate(sxp)); + setAttrib(e, R_DimSymbol, R_NilValue); + x = attR(x,e); + UNPROTECT(1); + return x; +} + +static K from_integer_robject(SEXP sxp) { + K x; + J len = XLENGTH(sxp); + SEXP dim= getAttrib(sxp, R_DimSymbol); + if (isNull(dim)) { + //Process values + x = kintv(len,INTEGER(sxp)); + //Dictionary with atom values + SEXP keyNames= getAttrib(sxp, R_NamesSymbol); + if(!isNull(keyNames)&&len==XLENGTH(keyNames)) + return atom_value_dict(len, x, keyNames); + //Normal kdb+ list + return attR(x,sxp); + } + x = kinta(len,length(dim),INTEGER(dim),INTEGER(sxp)); + SEXP dimnames = getAttrib(sxp, R_DimNamesSymbol); + if (!isNull(dimnames)) + return attR(x,sxp); + SEXP e; + PROTECT(e = duplicate(sxp)); + setAttrib(e, R_DimSymbol, R_NilValue); + x = attR(x,e); + UNPROTECT(1); + return x; +} + +static K from_double_robject(SEXP sxp){ + K x; + I nano, span, bit64=isClass("integer64",sxp); + J len = XLENGTH(sxp); + SEXP dim= getAttrib(sxp, R_DimSymbol); + if (isNull(dim)) { + //Process values + nano = isClass("nanotime",sxp); + span = isClass("timespan",sxp); + if(nano || span || bit64) { + x=ktn(nano?KP:(span?KN:KJ),len); + DO(len,kJ(x)[i]=INT64(sxp)[i]) + if(nano) + DO(len,if(kJ(x)[i]!=nj)kJ(x)[i]-=epoch_offset) + } + else + x= kdoublev(len, REAL(sxp)); + //Dictionary with atom values + SEXP keyNames= getAttrib(sxp, R_NamesSymbol); + if(!isNull(keyNames)&&len==XLENGTH(keyNames)) + return atom_value_dict(len, x, keyNames); + else if(nano || span || bit64) + return x; + //Normal kdb+ list + return attR(x, sxp); + } + if(bit64) + x= klonga(len, length(dim), INTEGER(dim), (J*)REAL(sxp)); + else + x= kdoublea(len, length(dim), INTEGER(dim), REAL(sxp)); + SEXP dimnames= getAttrib(sxp, R_DimNamesSymbol); + if (!isNull(dimnames)) + return attR(x,sxp); + SEXP e; + PROTECT(e = duplicate(sxp)); + setAttrib(e, R_DimSymbol, R_NilValue); + if(bit64) + classgets(e,R_NilValue); + x = attR(x,e); + UNPROTECT(1); + return x; +} + +static K from_character_robject(SEXP sxp) { + K x; + J i, length = XLENGTH(sxp); + if (length == 1) + x = kp((char*) CHAR(STRING_ELT(sxp,0))); + else { + x = ktn(0, length); + for (i = 0; i < length; i++) + kK(x)[i] = kp((char*) CHAR(STRING_ELT(sxp,i))); + } + return attR(x,sxp); +} + +static K from_vector_robject(SEXP sxp) { + J i, length = LENGTH(sxp); + K x = ktn(0, length); + for (i = 0; i < length; i++) + kK(x)[i] = from_any_robject(VECTOR_ELT(sxp, i)); + SEXP colNames= getAttrib(sxp, R_NamesSymbol); + if(!isNull(colNames)&&length==XLENGTH(colNames)) { + K k= ktn(KS, length); + for(i= 0; i < length; i++) { + const char *colName= CHAR(STRING_ELT(colNames, i)); + kS(k)[i]= ss((S) colName); + } + return xD(k,x); + } + return attR(x, sxp); +} + +/* + * convert R arrays to K lists + * done for boolean, int, double + */ + +static K klogicv(J len, int *val) { + K x= ktn(KB, len); + DO(len, kG(x)[i]= (val)[i]); + return x; +} + +static K klogica(J len, int rank, int *shape, int *val) { + K x, y; + J i, j, r, c, k; + switch(rank) { + case 1: + x= kintv(len, val); + break; + case 2: + r= shape[0]; + c= shape[1]; + x= knk(0); + for(i= 0; i < r; i++) { + y= ktn(KB, c); + for(j= 0; j < c; j++) + kG(y)[j]= val[i + r * j]; + x= jk(&x, y); + }; + break; + default: + k= rank - 1; + r= shape[k]; + c= len / r; + x= knk(0); + for(i= 0; i < r; i++) + x= jk(&x, klogica(c, k, shape, val + c * i)); + } + return x; +} + +static K kintv(J len, int *val) { + K x = ktn(KI, len); + DO(len,kI(x)[i]=(val)[i]); + return x; +} + +static K kinta(J len, int rank, int *shape, int *val) { + K x,y; + J i,j,r,c,k; + switch (rank) { + case 1 : + x = kintv(len,val); + break; + case 2 : + r = shape[0]; + c = shape[1]; + x = knk(0); + for (i=0;i R interface */ +/*-----------------------------------------------------------*/ + +/*-----------------------------------------------*/ +/* Load Libraries */ +/*-----------------------------------------------*/ + +// Order of include does matter. +#include "embedr.h" +#include "common.h" + +/*-----------------------------------------------*/ +/* Functions */ +/*-----------------------------------------------*/ + +/* + * Given the appropriate names, types, and lengths, create an R named list. + */ +SEXP make_named_list(char **names, SEXPTYPE *types, Sint *lengths, Sint n) { + SEXP output, output_names, object = NULL_USER_OBJECT; + Sint elements; + PROTECT(output = NEW_LIST(n)); + PROTECT(output_names = NEW_CHARACTER(n)); + for(int i = 0; i < n; i++){ + elements = lengths[i]; + switch((int)types[i]) { + case LGLSXP: + PROTECT(object = NEW_LOGICAL(elements)); + break; + case INTSXP: + PROTECT(object = NEW_INTEGER(elements)); + break; + case REALSXP: + PROTECT(object = NEW_NUMERIC(elements)); + break; + case STRSXP: + PROTECT(object = NEW_CHARACTER(elements)); + break; + case VECSXP: + PROTECT(object = NEW_LIST(elements)); + break; + default: + error("Unsupported data type at %d %s\n", __LINE__, __FILE__); + } + SET_VECTOR_ELT(output, (Sint)i, object); + SET_STRING_ELT(output_names, i, COPY_TO_USER_STRING(names[i])); + } + SET_NAMES(output, output_names); + UNPROTECT(n+2); + return output; +} diff --git a/src/embedr_r2q.c b/src/embedr_r2q.c new file mode 100644 index 0000000..c0b6f2b --- /dev/null +++ b/src/embedr_r2q.c @@ -0,0 +1,282 @@ +/*-----------------------------------------------------------*/ +/* File: r2q_ex.c */ +/* Overview: Distinct code in embedR for R -> Q interface */ +/*-----------------------------------------------------------*/ + +/*-----------------------------------------------*/ +/* Load Libraries */ +/*-----------------------------------------------*/ + +// Order of include does matter. +#include "embedr.h" +#include "socketpair.h" +#include "common.h" + +//%% Socket Library %%//vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv/ + +#ifdef _WIN32 +#pragma comment(lib, "ws2_32.lib") +SOCKET spair[2]; +#else +#define SOCKET_ERROR -1 +I spair[2]; +#endif + +/*-----------------------------------------------*/ +/* List of Functions */ +/*-----------------------------------------------*/ + +/* + * User interface + */ + +EXP K ropen(K x); +EXP K rclose(K x); +EXP K rexec(K x); +EXP K rget(K x); +EXP K rset(K x,K y); +static K rcmd(int type,K x); + +/*-----------------------------------------------*/ +/* Global Variable */ +/*-----------------------------------------------*/ + +#ifdef _WIN32 +// initialise thread-local. Will fail in other threads. Ideally need to check if +// on q main thread. +__declspec(thread) int ROPEN= -1; +__declspec(thread) int RLOAD= 0; +#else +// initialise thread-local. Will fail in other threads. Ideally need to check if +// on q main thread. +__thread int ROPEN=-1; +__thread int RLOAD=0; +#endif + +/*-----------------------------------------------*/ +/* Functions */ +/*-----------------------------------------------*/ + +#if(defined(_WIN32) && (defined(_MSC_VER))) + +/* Windows sleep in 100ns units */ +BOOLEAN nanosleep(LONGLONG ns) { + /* Declarations */ + HANDLE timer; /* Timer handle */ + LARGE_INTEGER li; /* Time defintion */ + /* Create timer */ + if(!(timer= CreateWaitableTimer(NULL, TRUE, NULL))) + return FALSE; + /* Set timer properties */ + li.QuadPart= -ns; + if(!SetWaitableTimer(timer, &li, 0, NULL, NULL, FALSE)) { + CloseHandle(timer); + return FALSE; + } + /* Start & wait for timer */ + WaitForSingleObject(timer, INFINITE); + /* Clean resources */ + CloseHandle(timer); + /* Slept without problems */ + return TRUE; +} +#endif + +/* + * Conversion from R to Q + */ + +K from_pairlist_robject(SEXP sxp) { + K x = ktn(0,2*length(sxp)); + SEXP s = sxp;J i; + for(i=0;in;i+=2) { + kK(x)[i] = from_any_robject(CAR(s)); + kK(x)[i+1] = from_any_robject(TAG(s)); + s=CDR(s); + } + return attR(x,sxp); +} + +/* + * various utilities + */ + +/* get k string or symbol name */ +static char * getkstring(K x) { + char *s=NULL; + int len; + switch (xt) { + case -KC : + s = calloc(2,1); s[0] = xg; + break; + case KC : + s = calloc(1+xn,1); memmove(s, xG, xn); + break; + case -KS : // TODO: xs is already 0 terminated and fixed. can just return xs + len = 1+strlen(xs); + s = calloc(len,1); memmove(s, xs, len); break; + default : + krr("invalid name"); + } + return s; +} + +/* + * The public interface used from Q. + */ + +void* pingthread; + +V* pingmain(V* v){ + while(1){ +#if(defined(_WIN32) && (defined(_MSC_VER))) + nanosleep(1000000); +#else + nanosleep(&(struct timespec){ .tv_sec= 0, .tv_nsec= 1000000 }, NULL); +#endif + send(spair[1], "M", 1, 0); + } +} + +K processR(I d){ + char buf[1024]; + /*MSG_DONTWAIT - set in sd1(-h,...) */ + while(0 < recv(d, buf, sizeof(buf), 0)) + ; + R_ProcessEvents(); + return (K)0; +} + +/* + * ropen argument is empty, 0 or 1 + * empty,0 --slave (R is quietest) + * 1 --verbose + */ + +EXP K ropen(K x) { + if(!RLOAD) return krr("main thread only"); + if (ROPEN >= 0) return ki(ROPEN); + int s,mode=0; char *argv[] = {"R","--slave"}; + if (x && (-KI ==x->t || -KJ ==x->t)) mode=(x->t==-KI?x->i:x->j)!=0; + if (mode) argv[1] = "--verbose"; + int argc = sizeof(argv)/sizeof(argv[0]); + s=Rf_initEmbeddedR(argc, argv); + if (s<0) return krr("open failed"); + if(dumb_socketpair(spair, 1) == -1) + return krr("Init failed for socketpair"); + sd1(-spair[0], &processR); + #ifndef _WIN32 + pthread_t t; + if(pthread_create(&t, NULL, pingmain, NULL)) + R krr("poller_thread"); + pingthread= &t; + #else + if(_beginthreadex(0,0,pingmain,NULL,0,0)==-1) + R krr("poller_thread"); + #endif + ROPEN=mode; + return ki(ROPEN); +} + +// note that embedded R can be initialised once. No open/close/open supported +// http://r.789695.n4.nabble.com/Terminating-and-restarting-an-embedded-R-instance-possible-td4641823.html +EXP K rclose(K x){R NULL;} +EXP K rexec(K x) { return rcmd(0,x); } +EXP K rget(K x) { return rcmd(1,x); } + +static char* ParseError[5]={"null","ok","incomplete","error","eof"}; + +K rcmd(int type,K x) { + if(!RLOAD) return krr("main thread only"); + if (ROPEN < 0) ropen(NULL); + SEXP e, p, r, xp; + char rerr[256];extern char R_ParseErrorMsg[256]; + int error; + ParseStatus status; + if(abs(x->t)==KS) + e=from_symbol_kobject(x); + else if(abs(x->t)==KC) + e=from_string_kobject(x); + else + return krr("type"); + PROTECT(e); + PROTECT(p=R_ParseVector(e, 1, &status, R_NilValue)); + if (status != PARSE_OK) { + UNPROTECT(2); + snprintf(rerr,sizeof(rerr),"%s: %s",ParseError[status], R_ParseErrorMsg); + return krr(rerr); + } + PROTECT(xp=VECTOR_ELT(p, 0)); + r=R_tryEvalSilent(xp, R_GlobalEnv, &error); + UNPROTECT(3); + R_ProcessEvents(); + if (error) { + snprintf(rerr,sizeof(rerr),"eval error: %s",R_curErrorBuf()); + return krr(rerr); + } + if (type==1) + return from_any_robject(r); + return (K)0; +} + +EXP K rset(K x,K y) { + if(!RLOAD) + return krr("main thread only"); + if (ROPEN < 0) + ropen(NULL); + ParseStatus status; + SEXP txt, sym, val; + char rerr[256];extern char R_ParseErrorMsg[256]; + char *name = getkstring(x); + /* generate symbol to check name is valid */ + PROTECT(txt=allocVector(STRSXP, 1)); + SET_STRING_ELT(txt, 0, mkChar(name)); + free(name); + PROTECT(sym = R_ParseVector(txt, 1, &status,R_NilValue)); + if (status != PARSE_OK) { + UNPROTECT(2); + snprintf(rerr,sizeof(rerr),"%s: %s",ParseError[status], R_ParseErrorMsg); + return krr(rerr); + } + if(SYMSXP != TYPEOF(VECTOR_ELT(sym,0))){ + UNPROTECT(2); + return krr("nyi"); + } + /* read back symbol string */ + const char *c = CHAR(PRINTNAME(VECTOR_ELT(sym,0))); + PROTECT(val = from_any_kobject(y)); + defineVar(install(c),val,R_GlobalEnv); + UNPROTECT(3); + R_ProcessEvents(); + return (K)0; +} + +// Preamble to quench compile error for MSVC +// https://stackoverflow.com/questions/1113409/attribute-constructor-equivalent-in-vc +#ifdef __cplusplus + #define INITIALIZER(f) \ + static void f(void); \ + struct f##_t_ { f##_t_(void) { f(); } }; static f##_t_ f##_; \ + static void f(void) +#elif defined(_MSC_VER) + #pragma section(".CRT$XCU",read) + #define INITIALIZER2_(f,p) \ + static void f(void); \ + __declspec(allocate(".CRT$XCU")) void (*f##_)(void) = f; \ + __pragma(comment(linker,"/include:" p #f "_")) \ + static void f(void) + #ifdef _WIN64 + #define INITIALIZER(f) INITIALIZER2_(f,"") + #else + #define INITIALIZER(f) INITIALIZER2_(f,"_") + #endif +#else + #define INITIALIZER(f) \ + static void f(void) __attribute__((constructor)); \ + static void f(void) +#endif + +INITIALIZER(__attach) +{ + RLOAD=1; +} diff --git a/src/k.h b/src/k.h deleted file mode 100644 index 86e3021..0000000 --- a/src/k.h +++ /dev/null @@ -1,148 +0,0 @@ -#ifndef KX -#define KX -typedef char*S,C;typedef unsigned char G;typedef short H;typedef int I;typedef long long J;typedef float E;typedef double F;typedef void V; -#ifdef __cplusplus -extern"C"{ -#endif -#if !defined(KXVER) -#error "Set KXVER=3 for kdb+3.0 or standalone c-api after 2011-04-20. Otherwise set KXVER=2. e.g. #define KXVER 3 or gcc -DKXVER=3" -#endif -#if KXVER>=3 -typedef struct k0{signed char m,a,t;C u;I r;union{G g;H h;I i;J j;E e;F f;S s;struct k0*k;struct{J n;G G0[1];};};}*K; -typedef struct{G g[16];}U; -#define kU(x) ((U*)kG(x)) -#define xU ((U*)xG) -extern K ku(U),ktn(I,J),kpn(S,J); -extern I setm(I); -#define DO(n,x) {J i=0,_i=(n);for(;i<_i;++i){x;}} -#else -typedef struct k0{I r;H t,u;union{G g;H h;I i;J j;E e;F f;S s;struct k0*k;struct{I n;G G0[1];};};}*K; -extern K ktn(I,I),kpn(S,I); -#define DO(n,x) {I i=0,_i=(n);for(;i<_i;++i){x;}} -#endif -#ifdef __cplusplus -} -#endif -//#include -// vector accessors, e.g. kF(x)[i] for float&datetime -#define kG(x) ((x)->G0) -#define kC(x) kG(x) -#define kH(x) ((H*)kG(x)) -#define kI(x) ((I*)kG(x)) -#define kJ(x) ((J*)kG(x)) -#define kE(x) ((E*)kG(x)) -#define kF(x) ((F*)kG(x)) -#define kS(x) ((S*)kG(x)) -#define kK(x) ((K*)kG(x)) - -// type bytes qtype ctype accessor -#define KB 1 // 1 boolean char kG -#define UU 2 // 16 guid U kU -#define KG 4 // 1 byte char kG -#define KH 5 // 2 short short kH -#define KI 6 // 4 int int kI -#define KJ 7 // 8 long long kJ -#define KE 8 // 4 real float kE -#define KF 9 // 8 float double kF -#define KC 10 // 1 char char kC -#define KS 11 // * symbol char* kS - -#define KP 12 // 8 timestamp long kJ (nanoseconds from 2000.01.01) -#define KM 13 // 4 month int kI (months from 2000.01.01) -#define KD 14 // 4 date int kI (days from 2000.01.01) - -#define KN 16 // 8 timespan long kJ (nanoseconds) -#define KU 17 // 4 minute int kI -#define KV 18 // 4 second int kI -#define KT 19 // 4 time int kI (millisecond) - -#define KZ 15 // 8 datetime double kF (DO NOT USE) - -// table,dict -#define XT 98 // x->k is XD -#define XD 99 // kK(x)[0] is keys. kK(x)[1] is values. - -#ifdef __cplusplus -extern"C"{ -extern V m9(); -#else -extern V m9(V); -#endif -extern I khpun(const S,I,const S,I),khpu(const S,I,const S),khp(const S,I),okx(K),ymd(I,I,I),dj(I);extern V r0(K),sd0(I),kclose(I);extern S sn(S,I),ss(S); -extern K ktj(I,J),ka(I),kb(I),kg(I),kh(I),ki(I),kj(J),ke(F),kf(F),kc(I),ks(S),kd(I),kz(F),kt(I),sd1(I,K(*)(I)),dl(V*f,I), - knk(I,...),kp(S),ja(K*,V*),js(K*,S),jk(K*,K),jv(K*k,K),k(I,const S,...),xT(K),xD(K,K),ktd(K),r1(K),krr(const S),orr(const S),dot(K,K),b9(I,K),d9(K); -#ifdef __cplusplus -} -#endif - -// nulls(n?) and infinities(w?) -#define nh ((I)0xFFFF8000) -#define wh ((I)0x7FFF) -#define ni ((I)0x80000000) -#define wi ((I)0x7FFFFFFF) -#define nj ((J)0x8000000000000000LL) -#define wj 0x7FFFFFFFFFFFFFFFLL -#if defined(WIN32) || defined(_WIN32) -#define nf (log(-1.0)) -#define wf (-log(0.0)) -#if !defined(isnan) -#define isnan _isnan -#endif -#define finite _finite -extern double log(double); -#else -#define nf (0/0.0) -#define wf (1/0.0) -#define closesocket(x) close(x) -#endif - -// remove more clutter -#define O printf -#define R return -#define Z static -#define P(x,y) {if(x)R(y);} -#define U(x) P(!(x),0) -#define SW switch -#define CS(n,x) case n:x;break; -#define CD default - -#define ZV Z V -#define ZK Z K -#define ZH Z H -#define ZI Z I -#define ZJ Z J -#define ZE Z E -#define ZF Z F -#define ZC Z C -#define ZS Z S - -#define K1(f) K f(K x) -#define K2(f) K f(K x,K y) -#define TX(T,x) (*(T*)((G*)(x)+8)) -#define xr x->r -#define xt x->t -#define xu x->u -#define xn x->n -#define xx xK[0] -#define xy xK[1] -#define xg TX(G,x) -#define xh TX(H,x) -#define xi TX(I,x) -#define xj TX(J,x) -#define xe TX(E,x) -#define xf TX(F,x) -#define xs TX(S,x) -#define xk TX(K,x) -#define xG x->G0 -#define xH ((H*)xG) -#define xI ((I*)xG) -#define xJ ((J*)xG) -#define xE ((E*)xG) -#define xF ((F*)xG) -#define xS ((S*)xG) -#define xK ((K*)xG) -#define xC xG -#define xB ((G*)xG) - -#endif - diff --git a/src/qserver.c b/src/qserver.c deleted file mode 100644 index 8e837fb..0000000 --- a/src/qserver.c +++ /dev/null @@ -1,99 +0,0 @@ -/* - * Q server for R - */ - -/* - * The public interface used from R. - */ - -#ifdef WIN32 -#define EXPORT __declspec(dllexport) -#else -#define EXPORT -#endif - -EXPORT SEXP kx_r_open_connection(SEXP); -EXPORT SEXP kx_r_close_connection(SEXP); -EXPORT SEXP kx_r_execute(SEXP c, SEXP); - -/* - * Open a connection to an existing kdb+ process. - * - * If we just have a host and port we call khp from the kdb+ interface. - * If we have a host, port, "username:password" we call instead khpu. - */ -SEXP kx_r_open_connection(SEXP whence) -{ - SEXP result; - int connection, port; - char *host; - int length = GET_LENGTH(whence); - if (length < 2) - error("Can't connect with so few parameters.."); - - port = INTEGER_POINTER (VECTOR_ELT(whence, 1))[0]; - host = (char*) CHARACTER_VALUE(VECTOR_ELT(whence, 0)); - - if (2 == length) - connection = khp(host, port); - else { - char *user = (char*) CHARACTER_VALUE(VECTOR_ELT (whence, 2)); - connection = khpu(host, port, user); - } - if (!connection) - error("Could not authenticate"); - else if (connection < 0) { -#ifdef WIN32 - char buf[256]; - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(), - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), buf, 256, NULL); - error(buf); -#else - error(strerror(errno)); -#endif - } - PROTECT(result = NEW_INTEGER(1)); - INTEGER_POINTER(result)[0] = connection; - UNPROTECT(1); - return result; -} - -/* - * Close a connection to an existing kdb+ process. - */ -SEXP kx_r_close_connection(SEXP connection) -{ - SEXP result; - - /* Close the connection. */ - kclose(INTEGER_VALUE(connection)); - - PROTECT(result = NEW_INTEGER(1)); - INTEGER_POINTER(result)[0] = 0; - UNPROTECT(1); - return result; -} - -/* - * Execute a kdb+ query over the given connection. - */ -SEXP kx_r_execute(SEXP connection, SEXP query) -{ - K result; - SEXP s; - kx_connection = INTEGER_VALUE(connection); - - result = k(kx_connection, (char*) CHARACTER_VALUE(query), (K)0); - if (0 == result) { - error("Error: not connected to kdb+ server\n"); - } - else if (-128 == result->t) { - char *e = calloc(strlen(result->s) + 1, 1); - strcpy(e, result->s); - r0(result); - error("Error from kdb+: `%s\n", e); - } - s = from_any_kobject(result); - r0(result); - return s; -} diff --git a/src/rserver.c b/src/rserver.c deleted file mode 100644 index a21e12a..0000000 --- a/src/rserver.c +++ /dev/null @@ -1,488 +0,0 @@ -/* - * R server for Q - */ -/* - * The public interface used from Q. - * https://cran.r-project.org/doc/manuals/r-release/R-ints.pdf - * https://cran.r-project.org/doc/manuals/r-release/R-exts.html - */ -K ropen(K x); -K rclose(K x); -K rcmd(K x); -K rget(K x); -K rset(K x,K y); - -ZK rexec(int type,K x); -ZK kintv(J len, int *val); -ZK kinta(J len, int rank, int *shape, int *val); -ZK kdoublev(J len, double *val); -ZK kdoublea(J len, int rank, int *shape, double *val); -ZK from_any_robject(SEXP sxp); - -__thread int ROPEN=-1; // initialise thread-local. Will fail in other threads. Ideally need to check if on q main thread. -__thread int RLOAD=0; - -/* - * convert R SEXP into K object. - */ -ZK from_any_robject(SEXP); -ZK error_broken_robject(SEXP); -ZK from_null_robject(SEXP); -ZK from_symbol_robject(SEXP); -ZK from_pairlist_robject(SEXP); -ZK from_closure_robject(SEXP); -ZK from_language_robject(SEXP); -ZK from_char_robject(SEXP); -ZK from_logical_robject(SEXP); -ZK from_integer_robject(SEXP); -ZK from_double_robject(SEXP); -ZK from_character_robject(SEXP); -ZK from_vector_robject(SEXP); -ZK from_raw_robject(SEXP sxp); -ZK from_nyi_robject(S m,SEXP sxp); - -ZK from_any_robject(SEXP sxp) -{ - K result = 0; - int type = TYPEOF(sxp); - switch (type) { - case NILSXP : return from_null_robject(sxp); break; /* nil = NULL */ - case SYMSXP : return from_symbol_robject(sxp); break; /* symbols */ - case LISTSXP : return from_pairlist_robject(sxp); break; /* lists of dotted pairs */ - case CLOSXP : return from_closure_robject(sxp); break; /* closures */ - case ENVSXP : return from_nyi_robject("environment",sxp); break; /* environments */ - case PROMSXP : return from_nyi_robject("promise",sxp); break; /* promises: [un]evaluated closure arguments */ - case LANGSXP : return from_language_robject(sxp); break; /* language constructs (special lists) */ - case SPECIALSXP : return from_nyi_robject("special",sxp); break; /* special forms */ - case BUILTINSXP : return from_nyi_robject("builtin",sxp); break; /* builtin non-special forms */ - case CHARSXP : return from_char_robject(sxp); break; /* "scalar" string type (internal only)*/ - case LGLSXP : return from_logical_robject(sxp); break; /* logical vectors */ - case INTSXP : return from_integer_robject(sxp); break; /* integer vectors */ - case REALSXP : return from_double_robject(sxp); break; /* real variables */ - case CPLXSXP : return from_nyi_robject("complex", sxp); break; /* complex variables */ - case STRSXP : return from_character_robject(sxp); break; /* string vectors */ - case DOTSXP : return from_nyi_robject("dot",sxp); break; /* dot-dot-dot object */ - case ANYSXP : return error_broken_robject(sxp); break; /* make "any" args work */ - case VECSXP : return from_vector_robject(sxp); break; /* generic vectors */ - case EXPRSXP : return from_nyi_robject("exprlist",sxp); break; /* sxps vectors */ - case BCODESXP : return from_nyi_robject("bcode",sxp); break; /* byte code */ - case EXTPTRSXP : return from_nyi_robject("external",sxp); break; /* external pointer */ - case WEAKREFSXP : return error_broken_robject(sxp); break; /* weak reference */ - case RAWSXP : return from_raw_robject(sxp); break; /* raw bytes */ - case S4SXP : return from_nyi_robject("s4",sxp); break; /* S4 non-vector */ - - case NEWSXP : return error_broken_robject(sxp); break; /* fresh node created in new page */ - case FREESXP : return error_broken_robject(sxp); break; /* node released by GC */ - case FUNSXP : return from_nyi_robject("fun",sxp); break; /* Closure or Builtin */ - } - return result; -} - -ZK dictpairlist(SEXP sxp) -{ - K k = ktn(0,length(sxp)); - K v = ktn(0,length(sxp)); - SEXP s = sxp;J i; - for(i=0;in;i+=2) { - kK(x)[i] = from_any_robject(CAR(s)); - kK(x)[i+1] = from_any_robject(TAG(s)); - s=CDR(s); - } - return attR(x,sxp); -} - -ZK from_closure_robject(SEXP sxp) -{ - K x = from_any_robject(FORMALS(sxp)); - K y = from_any_robject(BODY(sxp)); - return attR(knk(2,x,y),sxp); -} - -ZK from_language_robject(SEXP sxp) -{ - K x = knk(0); - SEXP s = sxp; - while (0 < length(s)) { - x = jk(&x,from_any_robject(CAR(s))); - s = CDR(s); - } - return attR(x,sxp); -} - -ZK from_char_robject(SEXP sxp) -{ - K x = kpn((S)CHAR(STRING_ELT(sxp,0)),LENGTH(sxp)); - return attR(x,sxp); -} - -ZK from_logical_robject(SEXP sxp) -{ - K x; - J len = XLENGTH(sxp); - int *s = malloc(len*sizeof(int)); - DO(len,s[i]=LOGICAL_POINTER(sxp)[i]); - SEXP dim = GET_DIM(sxp); - if (isNull(dim)) { - x = kintv(len,s); - free(s); - return attR(x,sxp); - } - x = kinta(len,length(dim),INTEGER(dim),s); - free(s); - SEXP dimnames = GET_DIMNAMES(sxp); - if (!isNull(dimnames)) - return attR(x,sxp); - SEXP e; - PROTECT(e = duplicate(sxp)); - SET_DIM(e, R_NilValue); - x = attR(x,e); - UNPROTECT(1); - return x; -} - -ZK from_integer_robject(SEXP sxp) -{ - K x; - J len = XLENGTH(sxp); - int *s = malloc(len*sizeof(int)); - DO(len,s[i]=INTEGER_POINTER(sxp)[i]); - SEXP dim = GET_DIM(sxp); - if (isNull(dim)) { - x = kintv(len,s); - free(s); - return attR(x,sxp); - } - x = kinta(len,length(dim),INTEGER(dim),s); - free(s); - SEXP dimnames = GET_DIMNAMES(sxp); - if (!isNull(dimnames)) - return attR(x,sxp); - SEXP e; - PROTECT(e = duplicate(sxp)); - SET_DIM(e, R_NilValue); - x = attR(x,e); - UNPROTECT(1); - return x; -} - -ZK from_double_robject(SEXP sxp) -{ - K x; - J len = XLENGTH(sxp); - double *s = malloc(len*sizeof(double)); - DO(len,s[i]=REAL(sxp)[i]); - SEXP dim = GET_DIM(sxp); - if (isNull(dim)) { - x = kdoublev(len,s); - free(s); - return attR(x,sxp); - } - x = kdoublea(len,length(dim),INTEGER(dim),s); - free(s); - SEXP dimnames = GET_DIMNAMES(sxp); - if (!isNull(dimnames)) - return attR(x,sxp); - SEXP e; - PROTECT(e = duplicate(sxp)); - SET_DIM(e, R_NilValue); - x = attR(x,e); - UNPROTECT(1); - return x; -} - -ZK from_character_robject(SEXP sxp) -{ - K x; - J i, length = XLENGTH(sxp); - if (length == 1) - x = kp((char*) CHAR(STRING_ELT(sxp,0))); - else { - x = ktn(0, length); - for (i = 0; i < length; i++) { - xK[i] = kp((char*) CHAR(STRING_ELT(sxp,i))); - } - } - return attR(x,sxp); -} - -ZK from_vector_robject(SEXP sxp) -{ - J i, length = LENGTH(sxp); - K x = ktn(0, length); - for (i = 0; i < length; i++) { - xK[i] = from_any_robject(VECTOR_ELT(sxp, i)); - } - return attR(x,sxp); -} - -/* - * various utilities - */ - -/* get k string or symbol name */ -static char * getkstring(K x) -{ - char *s=NULL; - int len; - switch (xt) { - case -KC : - s = calloc(2,1); s[0] = xg; break; - case KC : - s = calloc(1+xn,1); memmove(s, xG, xn); break; - case -KS : // TODO: xs is already 0 terminated and fixed. can just return xs - len = 1+strlen(xs); - s = calloc(len,1); memmove(s, xs, len); break; - default : krr("invalid name"); - } - return s; -} - -/* - * convert R arrays to K lists - * done for int, double - */ - -ZK kintv(J len, int *val) -{ - K x = ktn(KI, len); - DO(len,kI(x)[i]=(val)[i]); - return x; -} - -ZK kinta(J len, int rank, int *shape, int *val) -{ - K x,y; - J i,j,r,c,k; - switch (rank) { - case 1 : x = kintv(len,val); break; - case 2 : - r = shape[0]; c = shape[1]; x = knk(0); - for (i=0;i= 0) return ki(ROPEN); - int s,mode=0; char *argv[] = {"R","--slave"}; - if (x && (-KI ==x->t || -KJ ==x->t)) mode=(x->t==-KI?x->i:x->j)!=0; - if (mode) argv[1] = "--verbose"; - int argc = sizeof(argv)/sizeof(argv[0]); - s=Rf_initEmbeddedR(argc, argv); - if (s<0) return krr("open failed"); - if(dumb_socketpair(spair, 1) == -1){ - return krr("Init failed for socketpair"); - } - sd1(-spair[0], &processR); - #ifndef WIN32 - pthread_t t; - if(pthread_create(&t, NULL, pingmain, NULL)) - R krr("poller_thread"); - pingthread= &t; - #else - if(_beginthreadex(0,0,pingmain,NULL,0,0)==-1) - R krr("poller_thread"); - #endif - ROPEN=mode; - return ki(ROPEN); -} - -// note that embedded R can be initialised once. No open/close/open supported -// http://r.789695.n4.nabble.com/Terminating-and-restarting-an-embedded-R-instance-possible-td4641823.html -K rclose(K x){R NULL;} -K rcmd(K x) { return rexec(0,x); } -K rget(K x) { return rexec(1,x); } - -static char* ParseError[5]={"null","ok","incomplete","error","eof"}; - - -K rexec(int type,K x) -{ - if(!RLOAD) return krr("main thread only"); - if (ROPEN < 0) ropen(NULL); - SEXP e, p, r, xp; - char rerr[256];extern char R_ParseErrorMsg[256]; - int error; - ParseStatus status; - if(abs(x->t)==KS) e=from_symbol_kobject(x); - else if(abs(x->t)==KC) e=from_string_kobject(x); - else return krr("type"); - PROTECT(e); - PROTECT(p=R_ParseVector(e, 1, &status, R_NilValue)); - if (status != PARSE_OK) { - UNPROTECT(2); - snprintf(rerr,sizeof(rerr),"%s: %s",ParseError[status], R_ParseErrorMsg); - return krr(rerr); - } - PROTECT(xp=VECTOR_ELT(p, 0)); - r=R_tryEvalSilent(xp, R_GlobalEnv, &error); - UNPROTECT(3); - R_ProcessEvents(); - if (error) { - snprintf(rerr,sizeof(rerr),"eval error: %s",R_curErrorBuf()); - return krr(rerr); - } - if (type==1) return from_any_robject(r); - return (K)0; //return knk(0) for cmd success? -} - -K rset(K x,K y) { - if(!RLOAD) return krr("main thread only"); - if (ROPEN < 0) ropen(NULL); - ParseStatus status; - SEXP txt, sym, val; - char rerr[256];extern char R_ParseErrorMsg[256]; - char *name = getkstring(x); - /* generate symbol to check name is valid */ - PROTECT(txt=allocVector(STRSXP, 1)); - SET_STRING_ELT(txt, 0, mkChar(name)); - free(name); - PROTECT(sym = R_ParseVector(txt, 1, &status,R_NilValue)); - if (status != PARSE_OK) { - UNPROTECT(2); - snprintf(rerr,sizeof(rerr),"%s: %s",ParseError[status], R_ParseErrorMsg); - return krr(rerr); - } - if(SYMSXP != TYPEOF(VECTOR_ELT(sym,0))){ - UNPROTECT(2); - return krr("nyi"); - } - /* read back symbol string */ - const char *c = CHAR(PRINTNAME(VECTOR_ELT(sym,0))); - PROTECT(val = from_any_kobject(y)); - defineVar(install(c),val,R_GlobalEnv); - UNPROTECT(3); - R_ProcessEvents(); - return (K)0; -} - -__attribute__((constructor)) V __attach(V) {RLOAD=1;} diff --git a/src/socketpair.c b/src/socketpair.c index 715ee2c..0316c8d 100644 --- a/src/socketpair.c +++ b/src/socketpair.c @@ -23,19 +23,9 @@ * add argument make_overlapped */ -#include +#include "socketpair.h" -#ifdef WIN32 -# include -# include -# include -# include -#else -# include -# include -#endif - -#ifdef WIN32 +#ifdef _WIN32 /* dumb_socketpair: * If make_overlapped is nonzero, both sockets created will be usable for diff --git a/src/w32/q.a b/src/w32/q.a deleted file mode 100644 index eed84b0..0000000 Binary files a/src/w32/q.a and /dev/null differ diff --git a/src/w64/q.a b/src/w64/q.a deleted file mode 100755 index 9087cd4..0000000 Binary files a/src/w64/q.a and /dev/null differ diff --git a/tests/test.q b/tests/test.q new file mode 100644 index 0000000..83cb88c --- /dev/null +++ b/tests/test.q @@ -0,0 +1,284 @@ +/ +* test R server for Q. +* # Note +* - When testing on travis CI `.r.install` should not be run; therefore commandline argument +* `test_data_frame` must be passed with its value `true`, e.g., +* $ q tests/test.q -test_data_frame true +* - `-s` flag must be passed to test limtation of main thread only. If `\s` is 0, Final test will be ignored. +\ + +//%% Commandline arguments %%//vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv/ + +COMMANDLINE_ARGS: .Q.opt .z.x; +if[`test_data_frame in key COMMANDLINE_ARGS; @[`COMMANDLINE_ARGS; `test_data_frame; {lower first x}]]; + +//%% Define Test Function/Variable %%//vvvvvvvvvvvvvvvvvvvvvvvvv/ + +HRULE:40#"+-"; +TESTCASE:0i; +SUCCESS:0i; +FAILURE:0i; + +PROGRESS:{[checkpoint] + -1 ""; + -1 HRULE; + -1 "\t",checkpoint; + -1 "\tScore:\t",string[SUCCESS],"/",string TESTCASE; + -1 "\tFail:\t",string[FAILURE],"/",string TESTCASE; + -1 HRULE; + -1 ""; + }; + +EQUAL:{[id;x;y] + TESTCASE+:1; + $[x~y; + SUCCESS+:1; + [FAILURE+:1; -1 "[",string[id],"] Fail:", -3!x] + ]; + }; + +//%% System Setting %%//vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv/ + +//Load embedR file +\l q/embedr.q + +//Set seed 42 +\S 42 + +//Set console width +\c 25 300 + +// set verbose mode +.r.open 1 + +//%% Test %%//vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv/ + +//Numerical Array//-------------------------/ + +PROGRESS["Test Start!!"]; + +.r.exec "a=array(1:24,c(2,3,4))" + +EQUAL[1; .r.get "dim(a)"; 2 3 4i]; +EQUAL[2; .r.get "a"; ((1 3 5i;2 4 6i);(7 9 11i;8 10 12i);(13 15 17i;14 16 18i);(19 21 23i;20 22 24i))]; + +if[3<=.z.K;.r.set["a";2?0Ng]] +EQUAL[3; .r.get "a"; ("84cf32c6-c711-79b4-2f31-6e85923decff";"22371003-8997-eed1-f4df-58fcdedd8376")]; + +.r.exec "b= 2 == array(1:24,c(2,3,4))" +EQUAL[4; .r.get "dim(b)"; 2 3 4i]; +EQUAL[5; .r.get "b"; ((000b;100b);(000b;000b);(000b;000b);(000b;000b))]; + +EQUAL[6; .r.get "1.1*array(1:24,c(2,3,4))"; ((1.1 3.3 5.5;2.2 4.4 6.6);(7.7 9.9 12.1;8.8 11.0 13.2);(14.3 16.5 18.7;15.4 17.6 19.8);(20.9 23.1 25.3;22.0 24.2 26.4))]; + +.r.set["xyz";1 2 3i] +EQUAL[7; .r.get "xyz"; 1 2 3i]; + +EQUAL[8; .r.get "pi"; (), acos -1]; +EQUAL[9; .r.get "2+3"; (), 5f]; +EQUAL[10; .r.get "11:11"; (), 11i]; +EQUAL[11; .r.get "11:15"; 11 12 13 14 15i]; +a:.r.get "matrix(1:6,2,3)" +EQUAL[12; a[1]; 2 4 6i]; +.r.exec "m=array(1:24,c(2,3,4))" +EQUAL[13; .r.get "m"; ((1 3 5i;2 4 6i);(7 9 11i;8 10 12i);(13 15 17i;14 16 18i);(19 21 23i;20 22 24i))]; +EQUAL[14; .r.get "length(m)"; (), 24i]; +EQUAL[15; .r.get "dim(m)"; 2 3 4i]; +EQUAL[16; .r.get "c(1,2,Inf,-Inf,NaN,NA)"; 1 2 0w -0w 0n 0n]; + +PROGRESS["Numeric Array Finished!!"]; + +//Plot Functionality//----------------------/ + +.r.exec "pdf(tempfile(\"t1\",fileext=\".pdf\"))" +.r.exec "plot(c(2,3,5,7,11))" +.r.exec "dev.off()" + +//Function Test//---------------------------/ + +.r.exec "x=factor(c('one','two','three','four'))" +EQUAL[17; .r.get "x"; `one`two`three`four]; +EQUAL[18; .r.get "mode(x)"; "numeric"]; +EQUAL[19; .r.get "typeof(x)"; "integer"]; +EQUAL[20; .r.get "c(TRUE,FALSE,NA,TRUE,TRUE,FALSE)"; 100110b]; +.r.exec "foo <- function(x,y) {x + 2 * y}" +.r.get "foo" +EQUAL[21; .r.get "typeof(foo)"; "closure"]; +EQUAL[22; .r.get "foo (5,3)"; (), 11f]; + +PROGRESS["Function Test Finished!!"]; + +//Object//-----------------------------------/ + +show .r.get "wilcox.test(c(1,2,3),c(4,5,6))" +.r.exec "data(OrchardSprays)" +show .r.get "OrchardSprays" + +// to install package in non-interactive way +// install.packages("zoo", repos="http://cran.r-project.org") +.r.get"install.packages" +//'Broken R object. +EQUAL[23; .r.get".GlobalEnv"; "environment"]; +//"environment" +EQUAL[24; .r.get"emptyenv()"; "environment"]; +//"environment" +EQUAL[25; .r.get".Internal"; "special"]; +//"special" +EQUAL[26; @[.r.exec; "typeof("; like[;"incomplete: *"]]; 1b]; +EQUAL[27; @[.r.exec; "typeof()"; like[;"eval error*"]]; 1b]; +EQUAL[28; .r.get each ("cos";".C";"floor";"Im";"cumsum";"nargs";"proc.time";"dim";"length";"names";".External"); ("builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin")]; +.r.get "getGeneric('+')" + +EQUAL[29; .r.get"as.raw(10)"; (), 0x0a]; +EQUAL[30; .r.get"as.logical(c(1,FALSE,NA))"; 100b]; + +PROGRESS["Object Test Finished!!"]; + +//Table//-----------------------------------/ + +// data.frame +EQUAL[31; .r.get"data.frame(a=1:3, b=c('a','b','c'),stringsAsFactors=TRUE)"; flip `a`b!(1 2 3i;`a`b`c)]; +EQUAL[32; .r.get"data.frame(a=1:3, b=c('a','b','c'),stringsAsFactors=FALSE)"; flip `a`b!(1 2 3i;1#/:("a";"b";"c"))]; +EQUAL[33; .r.get"data.frame(a=1:3)"; flip enlist[`a]!enlist (1 2 3i)]; +EQUAL[34; .r.get"data.frame()"; ()]; + +PROGRESS["Table Test Finished!!"]; + +//Dictionary//------------------------------/ + +.r.set["dictI"; `a`b`c!1 2 3i]; +EQUAL[35; .r.get"dictI"; `a`b`c!1 2 3i]; +.r.set["dictJ"; `a`b`c!1 2 3]; +EQUAL[36; .r.get"dictJ"; `a`b`c!1 2 3]; +.r.set["dictB"; `a`b`c!101b]; +EQUAL[37; .r.get"dictB"; `a`b`c!101b]; +.r.set["dictP"; `a`b`c!(2020.04.13D06:08:03.712336000; 2020.04.13D06:08:03.712336001; 2020.04.13D06:08:03.712336002)]; +EQUAL[38; .r.get"dictP"; `a`b`c!(2020.04.13D06:08:03.712336000; 2020.04.13D06:08:03.712336001; 2020.04.13D06:08:03.712336002)]; + +PROGRESS["Dictionary Test Finished!!"]; + +//Time//------------------------------------/ + +// timestamp +.r.set["tmstp"; 2020.03.16D17:30:45.123456789]; +EQUAL[39; .r.get"tmstp"; (), 2020.03.16D17:30:45.123456789]; + +// month +.r.set["mnth"; `month$/:2020.04.02 2010.01.29] +EQUAL[40; .r.get"mnth"; 2020.04 2010.01m]; + +// dates +EQUAL[41; .r.get"as.Date('2005-12-31')"; (), 2005.12.31]; +EQUAL[42; .r.get"as.Date(NA)"; (), 0Nd]; +EQUAL[43; .r.get"rep(as.Date('2005-12-31'),2)"; 2005.12.31 2005.12.31]; + +// datetime +.r.exec["Sys.setenv(TZ='UTC')"]; +EQUAL[44; .r.get"as.POSIXct(\"2018-02-18 04:00:01\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC')"; (),2018.02.18T04:00:01.000z]; +EQUAL[45; .r.get"as.POSIXlt(\"2018-02-18 04:00:01\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC')"; (),2018.02.18T04:00:01.000z]; +EQUAL[46; .r.get"c(as.POSIXct(\"2015-03-16 17:30:00\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC'), as.POSIXct(\"1978-06-01 12:30:59\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC'))"; (2015.03.16T17:30:00.000z; 1978.06.01T12:30:59.000z)]; +EQUAL[47; .r.get"c(as.POSIXlt(\"2015-03-16 17:30:00\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC'), as.POSIXlt(\"1978-06-01 12:30:59\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC'))"; (2015.03.16T17:30:00.000z; 1978.06.01T12:30:59.000z)]; +.r.set["dttm"; 2018.02.18T04:00:01.000z]; +EQUAL[48; .r.get"dttm"; (), 2018.02.18T04:00:01.000z]; + +// days +.r.set["days"; 1D 2D]; +EQUAL[49; .r.get"days"; 1D 2D]; +EQUAL[50; .r.get"as.difftime(c(1, 2), units=\"days\")"; 1D 2D]; + +// timespan +.r.set["tmspans"; 0D12 0D04:20:17.123456789 0D00:00:00.000000012] +EQUAL[51; .r.get"tmspans"; 0D12 0D04:20:17.123456789 0D00:00:00.000000012]; + +// minute +.r.set["mnt"; `minute$(2019.04.01D12:00:30; 2019.04.01D12:30:45)]; +EQUAL[52; .r.get "mnt"; 12:00 12:30]; +EQUAL[53; .r.get"as.difftime(c(1, 2), units=\"mins\")"; 00:01 00:02]; + +// second +.r.set["scnd"; `second$(2019.04.01D12:00:30; 2019.04.01D12:30:45)]; +EQUAL[54; .r.get"scnd"; 12:00:30 12:30:45]; +EQUAL[55; .r.get"as.difftime(c(1, 2), units=\"secs\")"; 00:00:01 00:00:02]; + +PROGRESS["Time Test Finished!!"]; + +//List//---------------------------------------/ + +//lang +EQUAL[56; .r.get "as.pairlist(1:10)"; (enlist 1i;();enlist 2i;();enlist 3i;();enlist 4i;();enlist 5i;();enlist 6i;();enlist 7i;();enlist 8i;();enlist 9i;();enlist 10i;())]; +EQUAL[57; .r.get "as.pairlist(TRUE)"; (enlist 1b; ())]; +EQUAL[58; .r.get "as.pairlist(as.raw(1))"; (enlist 0x01; ())]; +EQUAL[59; .r.get "pairlist('rnorm', 10L, 0.0, 2.0 )"; ("rnorm";();enlist 10i;();enlist 0f;();enlist 2f;())]; +.r.get "list(x ~ y + z)" +EQUAL[60; .r.get "list( c(1, 5), c(2, 6), c(3, 7) )"; (1 5f;2 6f;3 7f)]; +EQUAL[61; .r.get "matrix( 1:16+.5, nc = 4 )"; (1.5 5.5 9.5 13.5;2.5 6.5 10.5 14.5;3.5 7.5 11.5 15.5;4.5 8.5 12.5 16.5)]; +.r.get "Instrument <- setRefClass(Class='Instrument',fields=list('id'='character', 'description'='character'))" +.r.get "Instrument$accessors(c('id', 'description'))" +.r.get "Instrument$new(id='AAPL', description='Apple')" +EQUAL[62; .r.get "(1+1i)"; "complex"]; +EQUAL[63; .r.get "(0:9)^2"; 0 1 4 9 16 25 36 49 64 81f]; +EQUAL[64; .r.get"expression(rnorm, rnorm(10), mean(1:10))"; "expression"]; +EQUAL[65; .r.get"list( rep(NA_real_, 20L), rep(NA_real_, 6L) )"; (0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n;0n 0n 0n 0n 0n 0n)]; +EQUAL[66; .r.get"c(1, 2, 1, 1, NA, NaN, -Inf, Inf)"; 1 2 1 1 0n 0n -0w 0w]; + +PROGRESS["List Test Finished!!"]; + +//Q-Like R Interface//--------------------------/ + +// long vectors +.r.exec"x<-c(as.raw(1))" +//.r.exec"x[2147483648L]<-as.raw(1)" +EQUAL[67; count .r.get`x; 1]; + +EQUAL[68; .[.r.set;("x[0]";1); "nyi"~]; 1b]; +EQUAL[69; .r.get["c()"]; .r.get"NULL"]; +EQUAL[70; .r.get"c()"; ()]; +EQUAL[71; {@[.r.get;x;"type"~]}each (.z.p;0b;1;1f;{};([1 2 3]1 2 3)); 111111b]; +.r.set[`x;1] +EQUAL[72; .r.get each ("x";enlist "x";`x;`x`x); 1#/:(1;1;1;1)]; // ("x";"x")? + +PROGRESS["Q-Like R Command Test Finished!!"]; + +//Genral Test//----------------------------------/ + +.r.exec"rm(x)" + +// run gc +.r.get"gc()" + +.r.set["a";`sym?`a`b`c]; +`:x set string 10?`4; +.r.set["a";get `:x]; +hdel `:x; +hdel `$":x#"; + +// Finish testing if `test_data_frame` is not "true". +if[not "true" ~ COMMANDLINE_ARGS `test_data_frame; + PROGRESS["Completed!!"]; + exit 0 + ]; + +.r.install `data.table +.r.exec"library(data.table)" +.r.exec"a<-data.frame(a=c(1,2))" +EQUAL[73; .r.get`a; flip enlist[`a]!enlist (1 2f)]; +.r.exec "b<-data.table(a=c(1,2))" +EQUAL[74; .r.get`b; flip enlist[`a]!enlist (1 2f)]; +.r.exec"inspect <- function(x, ...) .Internal(inspect(x,...))" +.r.get`inspect +.r.get"substitute(log(1))" + +EQUAL[75; flip[`a`b!(`1`2`1;`a`b`b)]; .r.get"data.frame(a=as.factor(c(1,2,1)), b=c(\"a\",\"b\",\"b\"),stringsAsFactors=TRUE)"]; +EQUAL[76; flip[`a`b!(`1`2`1;1#/:("a";"b";"b"))]; .r.get"data.table(a=as.factor(c(1,2,1)), b=c(\"a\",\"b\",\"b\"))"]; +EQUAL[77; flip[`a`b!(`1`2`1;`10`20`30)]; .r.get"data.table(a=as.factor(c(1,2,1)), b=as.factor(c(10,20,30)))"]; + +// Finish testing if slave thread is not used. +if[0i ~ system "s"; + PROGRESS["Completed!!"]; + exit 0 + ]; + +EQUAL[78; all {.[.r.set;("x"; x);"main thread only"~]} peach 2#enlist ([]1 2); 1b]; +PROGRESS["Completed!!"]; + +exit 0 diff --git a/tests/test_old.q b/tests/test_old.q new file mode 100644 index 0000000..f0ff706 --- /dev/null +++ b/tests/test_old.q @@ -0,0 +1,319 @@ +/ +* test R server for Q +* These tests are for checking compatability with v1.2. +\ + +//%% Commandline arguments %%//vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv/ + +COMMANDLINE_ARGS: .Q.opt .z.x; +if[`test_data_frame in key COMMANDLINE_ARGS; @[`COMMANDLINE_ARGS; `test_data_frame; {lower first x}]]; + +//%% Define Test Function/Variable %%//vvvvvvvvvvvvvvvvvvvvvvvvv/ + +HRULE:40#"+-"; +TESTCASE:0i; +SUCCESS:0i; +FAILURE:0i; + +PROGRESS:{[checkpoint] + -1 ""; + -1 HRULE; + -1 "\t",checkpoint; + -1 "\tScore:\t",string[SUCCESS],"/",string TESTCASE; + -1 "\tFail:\t",string[FAILURE],"/",string TESTCASE; + -1 HRULE; + -1 ""; + }; + +EQUAL:{[id;x;y] + TESTCASE+:1; + $[x~y; + SUCCESS+:1; + [FAILURE+:1; -1 "[",string[id],"] Fail:", -3!x] + ]; + }; + +//%% System Setting %%//vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv/ + +//Load embedR file +\l q/embedr.q + +//Set seed 42 +\S 42 + +//Set console width +\c 25 300 + +// set verbose mode +Ropen 1 // set verbose mode + +//%% Test %%//vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv/ + +//Numerical Array//-------------------------/ + +PROGRESS["Test Start!!"]; + +Rcmd "a=array(1:24,c(2,3,4))" +EQUAL[1; Rget "dim(a)"; 2 3 4i]; +EQUAL[2; Rget "a"; ((1 3 5i;2 4 6i);(7 9 11i;8 10 12i);(13 15 17i;14 16 18i);(19 21 23i;20 22 24i))]; + +if[3<=.z.K; Rset["a";2?0Ng]] +EQUAL[3; Rget "a"; ("84cf32c6-c711-79b4-2f31-6e85923decff";"22371003-8997-eed1-f4df-58fcdedd8376")]; + +Rcmd "b= 2 == array(1:24,c(2,3,4))" +EQUAL[4; Rget "dim(b)"; 2 3 4i]; +// Type mapping issue of v1.2 +EQUAL[5; Rget "b"; ((0 0 0i;1 0 0i);(0 0 0i;0 0 0i);(0 0 0i;0 0 0i);(0 0 0i;0 0 0i))]; + +EQUAL[6; Rget "1.1*array(1:24,c(2,3,4))"; ((1.1 3.3 5.5;2.2 4.4 6.6);(7.7 9.9 12.1;8.8 11 13.2);(14.3 16.5 18.7;15.4 17.6 19.8);(20.9 23.1 25.3;22 24.2 26.4))]; + +Rset["xyz";1 2 3i] +EQUAL[7; Rget "xyz"; 1 2 3i]; + +EQUAL[8; Rget "pi"; (), acos -1]; +EQUAL[9; Rget "2+3"; (), 5f]; +EQUAL[10; Rget "11:11"; (), 11i]; +EQUAL[11; Rget "11:15"; 11 12 13 14 15i]; +a:Rget "matrix(1:6,2,3)" +EQUAL[12; a[1]; 2 4 6i]; +Rcmd "m=array(1:24,c(2,3,4))" +EQUAL[13; Rget "m"; ((1 3 5i;2 4 6i);(7 9 11i;8 10 12i);(13 15 17i;14 16 18i);(19 21 23i;20 22 24i))]; +EQUAL[14; Rget "length(m)"; (), 24i]; +EQUAL[15; Rget "dim(m)"; 2 3 4i]; +EQUAL[16; Rget "c(1,2,Inf,-Inf,NaN,NA)"; 1 2 0w -0w 0n 0n]; + +PROGRESS["Numeric Array Finished!!"]; + +//Plot Functionality//----------------------/ + +Rcmd "pdf(tempfile(\"t1\",fileext=\".pdf\"))" +Rcmd "plot(c(2,3,5,7,11))" +Rcmd "dev.off()" + +//Function Test//---------------------------/ + +Rcmd "x=factor(c('one','two','three','four'))" +EQUAL[17; Rget "x"; `one`two`three`four]; +EQUAL[18; Rget "mode(x)"; "numeric"]; +EQUAL[19; Rget "typeof(x)"; "integer"]; +// Type mapping issue of v1.2 +EQUAL[20; Rget "c(TRUE,FALSE,NA,TRUE,TRUE,FALSE)"; 1 0 0N 1 1 0i]; +Rcmd "foo <- function(x,y) {x + 2 * y}" +Rget "foo" +EQUAL[21; Rget "typeof(foo)"; "closure"]; +EQUAL[22; Rget "foo (5,3)"; (), 11f]; + +PROGRESS["Function Test Finished!!"]; + +//Object//-----------------------------------/ + +// Old output is: +// ((`names;`class)!(("statistic";"parameter";"p.value";"null.value";"alternative";"method";"data.name");"htest");((,`names!,,"W";,0f);();,0.1;(,`names!,"location shift";,0f);"two.sided";"Wilcoxon rank sum exact test";"c(1, 2, 3) and c(4, 5, 6)")) +// New output is: +// `statistic`parameter`p.value`null.value`alternative`method`data.name!((,`W)!,0f;();,0.1;(,`location shift)!,0f;"two.sided";"Wilcoxon rank sum exact test";"c(1, 2, 3) and c(4, 5, 6)") +Rget "wilcox.test(c(1,2,3),c(4,5,6))" +Rcmd "data(OrchardSprays)" +a:Rget "OrchardSprays" +a + +// to install package in non-interactive way +// install.packages("zoo", repos="http://cran.r-project.org") +Rget"install.packages" +//'Broken R object. +EQUAL[23; Rget".GlobalEnv"; "environment"]; +//"environment" +EQUAL[24; Rget"emptyenv()"; "environment"]; +//"environment" +EQUAL[25; Rget".Internal"; "special"]; +//"special" +EQUAL[26; @[Rcmd; "typeof("; like[;"incomplete: *"]]; 1b]; +EQUAL[27; @[Rcmd; "typeof()"; like[;"eval error*"]]; 1b]; +EQUAL[28; Rget each ("cos";".C";"floor";"Im";"cumsum";"nargs";"proc.time";"dim";"length";"names";".External"); ("builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin";"builtin")]; +Rget "getGeneric('+')" + +EQUAL[29; Rget"as.raw(10)"; (), 0x0a]; +// Type mapping issue of v1.2 +EQUAL[30; Rget"as.logical(c(1,FALSE,NA))"; 1 0 0Ni]; + +PROGRESS["Object Test Finished!!"]; + +//Table//-----------------------------------/ + +// data.frame +EQUAL[31; Rget"data.frame(a=1:3, b=c('a','b','c'),stringsAsFactors=TRUE)"; flip `a`b`row.names!(1 2 3i;`a`b`c;1 2 3)]; +EQUAL[32; Rget"data.frame(a=1:3, b=c('a','b','c'),stringsAsFactors=FALSE)"; flip `a`b`row.names!(1 2 3i;(enlist "a";enlist "b";enlist "c");1 2 3)]; +EQUAL[33; Rget"data.frame(a=1:3)"; flip `a`row.names!(1 2 3i;1 2 3)]; +EQUAL[34; Rget"data.frame()"; ()]; + +PROGRESS["Table Test Finished!!"]; + +//Dictionary//------------------------------/ + +Rset["dictI"; `a`b`c!1 2 3i]; +// Type mapping issue in v1.2 +// Key has type 0 +EQUAL[35; Rget"dictI"; (enlist[`names]!enlist 1#/:("a"; "b"; "c"); 1 2 3i)]; +Rset["dictJ"; `a`b`c!1 2 3]; +// Type mapping issue in v1.2 +// Key has type 0 +EQUAL[36; Rget"dictJ"; (enlist[`names]!enlist 1#/:("a"; "b"; "c"); 1 2 3f)]; +Rset["dictB"; `a`b`c!101b]; +// Type mapping issue in v1.2 +// Key has type 0 +EQUAL[37; Rget"dictB"; (enlist[`names]!enlist 1#/:("a"; "b"; "c"); 1 0 1i)]; +Rset["dictP"; `a`b`c!(2020.04.13D06:08:03.712336000; 2020.04.13D06:08:03.712336001; 2020.04.13D06:08:03.712336002)]; +EQUAL[38; Rget"dictP"; 2020.04.13D06:08:03.712336128 2020.04.13D06:08:03.712336128 2020.04.13D06:08:03.712336128]; + +PROGRESS["Dictionary Test Finished!!"]; + +//Time//------------------------------------/ + +// timestamp +Rset["tmstp"; 2020.03.16D17:30:45.123456789]; +// Calculation is not acculate in v1.2. +EQUAL[39; Rget"tmstp"; (), 2020.03.16D17:30:45.123456768]; + +// month +Rset["mnth"; `month$/:2020.04.02 2010.01.29] +EQUAL[40; Rget"mnth"; 243 120i]; + +// dates +EQUAL[41; Rget"as.Date('2005-12-31')"; (), 2005.12.31]; +EQUAL[42; Rget"as.Date(NA)"; (), 0Nd]; +EQUAL[43; Rget"rep(as.Date('2005-12-31'),2)"; 2005.12.31 2005.12.31]; + +// datetime +Rcmd["Sys.setenv(TZ='UTC')"]; +// Type mapping issue in v1.2 +EQUAL[44; Rget"as.POSIXct(\"2018-02-18 04:00:01\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC')"; (), 2018.02.18D04:00:01.000000000]; +// Type mapping issue in v1.2 +EQUAL[45; Rget"c(as.POSIXct(\"2015-03-16 17:30:00\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC'), as.POSIXct(\"1978-06-01 12:30:59\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC'))"; 2015.03.16D17:30:00.000000000 1978.06.01D12:30:59.000000000]; +// POSIXlt is not supported +EQUAL[46; Rget"c(as.POSIXlt(\"2015-03-16 17:30:00\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC'), as.POSIXlt(\"1978-06-01 12:30:59\", format=\"%Y-%m-%d %H:%M:%S\", tz='UTC'))"; (2015.03.16T17:30:00.000z; 1978.06.01T12:30:59.000z)]; +Rset["dttm"; 2018.02.18T04:00:01.000z]; +// Type mapping issue in v1.2 +EQUAL[47; Rget"dttm"; (), 2018.02.18D04:00:01.000000000]; + +// days +Rset["days"; 1D 2D]; +// Type mapping issue in v1.2 +EQUAL[48; Rget"days"; 86400 172800f]; +// Type mapping issue in v1.2 +// Key is type 0. +EQUAL[49; Rget"as.difftime(c(1, 2), units=\"days\")"; ((`class;`units)!("difftime";"days");1 2f)]; + +// timespan +Rset["tmspans"; 0D12 0D04:20:17.123456789 0D00:00:00.000000012] +// Type mapping issue in v1.2 +EQUAL[50; Rget"tmspans"; (43200f; 86400 * 0D04:20:17.123456789 % 1D; 1.2e-08)]; + +// minute +Rset["mnt"; `minute$(2019.04.01D12:00:30; 2019.04.01D12:30:45)]; +// Type mapping issue in v1.2 +EQUAL[51; Rget "mnt"; 720 750i]; +// Type mapping issue in v1.2 +// Key is type 0. +EQUAL[52; Rget"as.difftime(c(1, 2), units=\"mins\")"; ((`class;`units)!("difftime";"mins");1 2f)]; + +// second +Rset["scnd"; `second$(2019.04.01D12:00:30; 2019.04.01D12:30:45)]; +// Type mapping issue in v1.2 +EQUAL[53; Rget"scnd"; 43230 45045i]; +// Type mapping issue in v1.2 +// Key is type 0. +EQUAL[54; Rget"as.difftime(c(1, 2), units=\"secs\")"; ((`class;`units)!("difftime";"secs");1 2f)]; + +PROGRESS["Time Test Finished!!"]; + +//List//---------------------------------------/ + +//lang +EQUAL[55; Rget "as.pairlist(1:10)"; (enlist 1i;();enlist 2i;();enlist 3i;();enlist 4i;();enlist 5i;();enlist 6i;();enlist 7i;();enlist 8i;();enlist 9i;();enlist 10i;())]; +// Type mapping issue of v1.2 +EQUAL[56; Rget "as.pairlist(TRUE)"; (enlist 1i; ())]; +EQUAL[57; Rget "as.pairlist(as.raw(1))"; (enlist 0x01; ())]; +EQUAL[58; Rget "pairlist('rnorm', 10L, 0.0, 2.0 )"; ("rnorm";();enlist 10i;();enlist 0f;();enlist 2f;())]; +Rget "list(x ~ y + z)" +EQUAL[59; Rget "list( c(1, 5), c(2, 6), c(3, 7) )"; (1 5f;2 6f;3 7f)]; +EQUAL[60; Rget "matrix( 1:16+.5, nc = 4 )"; (1.5 5.5 9.5 13.5;2.5 6.5 10.5 14.5;3.5 7.5 11.5 15.5;4.5 8.5 12.5 16.5)]; + +// Old output: +// ((`className;`package;`generator;`class)!((,`package!,".GlobalEnv";"Instrument");".GlobalEnv";((`.xData;`class)!("environment";(,`package!,"methods";"refGeneratorSlot"));"S4");(,`package!,"methods";"refObjectGenerator"));((`;`...);(`new;(,`package!,".GlobalEnv";"Instrument");`...))) +// New output: +// ((((".GlobalEnv";`package);"Instrument");`className;".GlobalEnv";`package;(("environment";`.xData;(("methods";`package);"refGeneratorSlot");`class);"S4");`generator;(("methods";`package);"refObjectGenerator");`class);((`;`...);(`new;((".GlobalEnv";`package);"Instrument");`...))) +Rget "Instrument <- setRefClass(Class='Instrument',fields=list('id'='character', 'description'='character'))" +// Old output: +// (,`names!,("getId";"setId";"getDescription";"setDescription");((();`id);((`;`value);(`{;(`<<-;`id;`value);(`invisible;`value)));(();`description);((`;`value);(`{;(`<<-;`description;`value);(`invisible;`value))))) +// New output: +// `getId`setId`getDescription`setDescription!((();`id);((`;`value);(`{;(`<<-;`id;`value);(`invisible;`value)));(();`description);((`;`value);(`{;(`<<-;`description;`value);(`invisible;`value)))) +Rget "Instrument$accessors(c('id', 'description'))" +// Old output: +// ((`.xData;`class)!("environment";(,`package!,".GlobalEnv";"Instrument"));"S4") +// New output: +// (("environment";`.xData;((".GlobalEnv";`package);"Instrument");`class);"S4") +Rget "Instrument$new(id='AAPL', description='Apple')" +EQUAL[61; Rget "(1+1i)"; "complex"]; +EQUAL[62; Rget "(0:9)^2"; 0 1 4 9 16 25 36 49 64 81f]; +EQUAL[63; Rget"expression(rnorm, rnorm(10), mean(1:10))"; "expression"]; +EQUAL[64; Rget"list( rep(NA_real_, 20L), rep(NA_real_, 6L) )"; (0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n 0n;0n 0n 0n 0n 0n 0n)]; +EQUAL[65; Rget"c(1, 2, 1, 1, NA, NaN, -Inf, Inf)"; 1 2 1 1 0n 0n -0w 0w]; + +//Q-Like R Interface//--------------------------/ + +// long vectors +Rcmd"x<-c(as.raw(1))" +//Rcmd"x[2147483648L]<-as.raw(1)" +EQUAL[66; count Rget`x; 1]; + +EQUAL[67; .[Rset;("x[0]";1); "nyi"~]; 1b]; +EQUAL[68; Rget["c()"]; Rget"NULL"]; +EQUAL[69; Rget"c()"; ()]; +EQUAL[70; {@[Rget;x;"type"~]}each (.z.p;0b;1;1f;{};([1 2 3]1 2 3)); 111111b]; +Rset[`x;1] +EQUAL[71; Rget each ("x";enlist "x";`x;`x`x); 1#/:(1f;1f;1f;1f)]; // ("x";"x")? + +PROGRESS["Q-Like R Command Test Finished!!"]; + +//Genral Test//----------------------------------/ + +Rcmd"rm(x)" + +// run gc +Rget"gc()" + +Rset["a";`sym?`a`b`c] +`:x set string 10?`4; +Rset["a";get `:x] +hdel `:x; +hdel `$":x#"; + +// Finish testing if `test_data_frame` is not "true". +if[not "true" ~ COMMANDLINE_ARGS `test_data_frame; + PROGRESS["Completed!!"]; + exit 0 + ]; + +Rinstall`data.table +Rcmd"library(data.table)" +Rcmd"a<-data.frame(a=c(1,2))" +EQUAL[72; Rget`a; flip `a`row.names!(1 2f;1 2)]; +Rcmd "b<-data.table(a=c(1,2))" +EQUAL[73; Rget`b; flip `a`row.names!(1 2f;1 2)]; +Rcmd"inspect <- function(x, ...) .Internal(inspect(x,...))" +Rget`inspect +Rget"substitute(log(1))" + +EQUAL[74; Rget"data.frame(a=as.factor(c(1,2,1)), b=c(\"a\",\"b\",\"b\"),stringsAsFactors=TRUE)"; flip `a`b`row.names!(`1`2`1;`a`b`b;1 2 3)]; +EQUAL[75; Rget"data.table(a=as.factor(c(1,2,1)), b=c(\"a\",\"b\",\"b\"))"; flip `a`b`row.names!(`1`2`1;1#/:("a";"b";"b");1 2 3)]; +EQUAL[76; Rget"data.table(a=as.factor(c(1,2,1)), b=as.factor(c(10,20,30)))"; flip `a`b`row.names!(`1`2`1;`10`20`30;1 2 3)]; + +// Finish testing if slave thread is not used. +if[0i ~ system "s"; + PROGRESS["Completed!!"]; + exit 0 + ]; + +EQUAL[77; all {.[Rset;("x";0N!x);"main thread only"~]} peach 2#enlist ([]1 2); 1b]; +PROGRESS["Completed!!"]; + +exit 0 diff --git a/win_install/w32.sh b/win_install/w32.sh deleted file mode 100644 index 8c21d41..0000000 --- a/win_install/w32.sh +++ /dev/null @@ -1,5 +0,0 @@ -R32=`R.exe RHOME`/bin/i386 -export PATH=$R32:"$PATH" -rm -f embedr.o -$R32/R.exe CMD SHLIB -o w32/embedr.dll embedr.c src/w32/q.a -cp w32/embedr.dll $QHOME/w32 diff --git a/win_install/w64.sh b/win_install/w64.sh deleted file mode 100644 index c42d6bf..0000000 --- a/win_install/w64.sh +++ /dev/null @@ -1,5 +0,0 @@ -R64=`R.exe RHOME`/bin/x64 -export PATH=$R64:"$PATH" -rm -f embedr.o -$R64/R.exe CMD SHLIB -o w64/embedr.dll embedr.c src/w64/q.a -cp w64/embedr.dll $QHOME/w64