├── .Rbuildignore ├── LICENSE ├── tests ├── test-all.R └── testthat │ └── test-SimpFort.R ├── NAMESPACE ├── .gitignore ├── README.md ├── src ├── Makevars ├── fortloopc.c └── fortloopf.f95 ├── inst └── NEWS.Rd ├── man ├── SimpFort-internal.Rd └── SimpFort.Rd ├── SimpFort.Rproj ├── DESCRIPTION └── R └── LLC.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2018 2 | COPYRIGHT HOLDER: Avraham Adler -------------------------------------------------------------------------------- /tests/test-all.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | test_check("SimpFort") 3 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | useDynLib(SimpFort, .registration=TRUE) 2 | exportPattern("^[[:alpha:]]+") 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | src/*.o 6 | src/*.so 7 | src/*.dll 8 | src/*.mod 9 | README.html 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # SimpFort 2 | 3 | **SimpFort** is a toy `R` package showing a basic interface between R and Fortran. Please see [my blog](https://www.avrahamadler.com/2018/12/09/the-need-for-speed-part-1-building-an-r-package-with-fortran/) for the corresponding post. 4 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 2 | 3 | C_OBJS = fortloopc.o 4 | FT_OBJS = fortloopf.o 5 | 6 | all: 7 | @$(MAKE) $(SHLIB) 8 | @rm -f *.mod *.o 9 | 10 | $(SHLIB): $(FT_OBJS) $(C_OBJS) 11 | 12 | fortloopc.o: fortloopf.o 13 | -------------------------------------------------------------------------------- /inst/NEWS.Rd: -------------------------------------------------------------------------------- 1 | \name{NEWS} 2 | \alias{NEWS} 3 | \title{NEWS file for the toy SimpFort package} 4 | 5 | \section{Version 0.0.2 (2021-02-09)}{ 6 | \itemize{ 7 | \item Add .Fortran interface 8 | } 9 | } 10 | 11 | \section{Version 0.0.1 (2018-12-19)}{ 12 | \itemize{ 13 | \item Initial version. 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /man/SimpFort-internal.Rd: -------------------------------------------------------------------------------- 1 | \name{SimpFort-internal} 2 | 3 | %% These are the internal C functions called by the package 4 | \alias{c_llc_f} 5 | 6 | \title{Internal Delaporte Functions} 7 | \description{ 8 | Internal Delaporte functions 9 | } 10 | \details{ 11 | These are not to be called directly by the user. 12 | } 13 | \keyword{internal} 14 | -------------------------------------------------------------------------------- /SimpFort.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageInstallArgs: --preclean --clean 20 | PackageBuildBinaryArgs: --preclean --clean 21 | PackageCheckArgs: --as-cran 22 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: SimpFort 2 | Type: Package 3 | Title: Simple Example of using Fortran with R 4 | Version: 0.0.2 5 | Date: 2021-02-09 6 | Authors@R: c(person(given="Avraham", family="Adler", role=c("aut", "cph", "cre"), email="Avraham.Adler@gmail.com", comment = c(ORCID = "0000-0002-3039-0703"))) 7 | Description: Very basic example of using compiled free-form Fortran with R as a package. Faster and safer than using the .Fortran interface. 8 | License: BSD_2_clause + file LICENSE 9 | LazyData: true 10 | NeedsCompilation: yes 11 | Suggests: testthat 12 | -------------------------------------------------------------------------------- /man/SimpFort.Rd: -------------------------------------------------------------------------------- 1 | \name{LLC_f} 2 | \alias{LLC_f} 3 | \title{Example function calling Fortran} 4 | \usage{ 5 | LLC_f(x, l, a) 6 | } 7 | \arguments{ 8 | \item{x}{Vector of losses} 9 | \item{l}{Layer limit} 10 | \item{a}{Layer attachment} 11 | } 12 | \description{ 13 | Calculates: \deqn{LLC = \sum_{i=0}^n {\max(0, \min(x_i - a, l))}}{LLC = SUM over x: max(0, min(x - a, l))} 14 | } 15 | \examples{ 16 | LLC_f(100000, 50000, 90000) # Should return 10000 17 | LLC_f(100000, 50000, 50000) # Should return 50000 18 | LLC_f(100000, 10000, 100000) # Should return 0 19 | } 20 | -------------------------------------------------------------------------------- /R/LLC.R: -------------------------------------------------------------------------------- 1 | LLC_f <- function(x, l, a) { 2 | if (length(l) > 1 | length(a) > 1) { 3 | stop("This toy example is restricted to singular values of the limit and attachment.")} 4 | .Call(c_llc_f, as.double(x), as.double(l), as.double(a)) 5 | } 6 | 7 | LLC_f2 <- function(x, l, a) { 8 | if (length(l) > 1 | length(a) > 1) { 9 | stop("This toy example is restricted to singular values of the limit and attachment.")} 10 | out <- .Fortran("llc_f2", x = as.double(x), n = length(x), l = as.double(l), 11 | a = as.double(a), llc = as.double(0)) 12 | out$llc 13 | } 14 | 15 | -------------------------------------------------------------------------------- /tests/testthat/test-SimpFort.R: -------------------------------------------------------------------------------- 1 | test_that("Calulation is accurate", { 2 | expect_equal(LLC_f(1e6, 3e5, 5e5), 3e5) 3 | expect_equal(LLC_f(c(1e6, 6e5), 3e5, 5e5), 4e5) 4 | expect_equal(LLC_f(1e6, 3e5, 8e5), 2e5) 5 | expect_equal(LLC_f(1e6, 3e5, 10e5), 0) 6 | }) 7 | 8 | test_that("Limit and Attachment is singular", { 9 | expect_error(LLC_f(c(1e6, 1e5), c(3e5, 2e5), 5e5)) 10 | expect_error(LLC_f(c(1e6, 1e5), 3e5, c(5e5, 6e5))) 11 | expect_error(LLC_f(c(1e6, 1e5), c(3e5, 2e5), c(5e5, 6e5))) 12 | }) 13 | 14 | test_that(".Fortran And .Call are equal", { 15 | expect_equal(LLC_f(1e6, 3e5, 5e5), LLC_f2(1e6, 3e5, 5e5)) 16 | expect_equal(LLC_f(c(1e6, 6e5), 3e5, 5e5), LLC_f2(c(1e6, 6e5), 3e5, 5e5)) 17 | expect_equal(LLC_f(1e6, 3e5, 8e5), LLC_f2(1e6, 3e5, 8e5)) 18 | expect_equal(LLC_f(1e6, 3e5, 10e5), LLC_f2(1e6, 3e5, 10e5)) 19 | }) 20 | -------------------------------------------------------------------------------- /src/fortloopc.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include // for NULL 4 | #include 5 | #include 6 | 7 | void F77_NAME(llc_f)(double *x, int n, double *l, double *a, double *ret); 8 | extern void F77_NAME(llc_f2)(double *x, int *n, double *l, double *a, double *ret); 9 | 10 | extern SEXP c_llc_f(SEXP x, SEXP l, SEXP a){ 11 | const int n = LENGTH(x); 12 | SEXP ret; 13 | PROTECT(ret = allocVector(REALSXP, 1)); 14 | F77_CALL(llc_f)(REAL(x), n, REAL(l), REAL(a), REAL(ret)); 15 | UNPROTECT(1); 16 | return(ret); 17 | } 18 | 19 | static const R_CallMethodDef CallEntries[] = { 20 | {"c_llc_f", (DL_FUNC) &c_llc_f, 3}, 21 | {NULL, NULL, 0} 22 | }; 23 | 24 | static const R_FortranMethodDef FEntries[] = { 25 | {"llc_f2", (DL_FUNC) &F77_NAME(llc_f2), 5}, 26 | {NULL, NULL, 0} 27 | }; 28 | 29 | void R_init_SimpFort (DllInfo *dll) { 30 | R_registerRoutines(dll, NULL, CallEntries, FEntries, NULL); 31 | R_useDynamicSymbols(dll, FALSE); 32 | } 33 | -------------------------------------------------------------------------------- /src/fortloopf.f95: -------------------------------------------------------------------------------- 1 | module fortloop 2 | use, intrinsic :: iso_c_binding 3 | 4 | implicit none 5 | private 6 | public :: llc_f 7 | 8 | contains 9 | 10 | subroutine llc_f(x, n, l, a, llc) bind(C, name = "llc_f_") 11 | 12 | real(kind = c_double), intent(in) :: l, a !limit & attach 13 | integer(kind = c_int), intent(in), value :: n !Length of x 14 | real(kind = c_double), intent(in), dimension(n) :: x !Vector of loss 15 | real(kind = c_double), intent(out) :: llc !Output variable 16 | integer :: i !Internal count 17 | 18 | llc = 0.0_c_double 19 | do i = 1, n 20 | llc = llc + max(0.0_c_double, min(x(i) - a, l)) 21 | end do 22 | 23 | end subroutine llc_f 24 | 25 | subroutine llc_f2(x, n, l, a, llc) bind(C, name = "llc_f2_") 26 | 27 | real(kind = c_double), intent(in) :: l, a !limit & attach 28 | integer(kind = c_int), intent(in) :: n !Length of x 29 | real(kind = c_double), intent(in), dimension(n) :: x !Vector of loss 30 | real(kind = c_double), intent(out) :: llc !Output variable 31 | integer :: i !Internal count 32 | 33 | llc = 0.0_c_double 34 | do i = 1, n 35 | llc = llc + max(0.0_c_double, min(x(i) - a, l)) 36 | end do 37 | 38 | end subroutine llc_f2 39 | 40 | end module fortloop 41 | --------------------------------------------------------------------------------