R Under development (unstable) (2024-05-20 r86569 ucrt) -- "Unsuffered Consequences"
Copyright (C) 2024 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> library("polyCub")
> 
> ## function to call an R CMD with environment variables
> ## 'env' specified as a named character vector
> Rcmd <- function (args, env = character(), ...) {
+     stopifnot(is.vector(env, mode = "character"),
+               !is.null(names(env)))
+     if (.Platform$OS.type == "windows") {
+         if (length(env)) {
+             ## the 'env' argument of system2() is not supported on Windows
+             setenv <- function (envs) {
+                 old <- Sys.getenv(names(envs), unset = NA, names = TRUE)
+                 set <- !is.na(envs)
+                 if (any(set)) do.call(Sys.setenv, as.list(envs[set]))
+                 if (any(!set)) Sys.unsetenv(names(envs)[!set])
+                 invisible(old)
+             }
+             oldenv <- setenv(env)
+             on.exit(setenv(oldenv))
+         }
+         system2(command = file.path(R.home("bin"), "Rcmd.exe"),
+                 args = args, ...)
+     } else {
+         system2(command = file.path(R.home("bin"), "R"),
+                 args = c("CMD", args),
+                 env = paste(names(env), env, sep = "="), ...)
+     }
+ }
> 
> ## test compilation with #include <polyCubAPI.h> for the polyCub_iso C-routine
> message("compiling polyiso_powerlaw.c using R CMD SHLIB")
compiling polyiso_powerlaw.c using R CMD SHLIB
> shlib_error <- Rcmd(
+     args = c("SHLIB", "--clean", "polyiso_powerlaw.c"),
+     env = c("PKG_CPPFLAGS" = paste0(
+                 "-I", system.file("include", package="polyCub")
+             ),
+             "R_TESTS" = "")
+ )
using C compiler: 'gcc.exe (GCC) 13.2.0'
make[1]: Entering directory '/d/RCompile/CRANincoming/R-devel/polyCub.Rcheck/tests'
gcc  -I"D:/RCompile/recent/R/include" -DNDEBUG -ID:/RCompile/CRANincoming/R-devel/lib/polyCub/include    -I"d:/rtools44/x86_64-w64-mingw32.static.posix/include"     -pedantic -Wstrict-prototypes -O2 -Wall  -mfpmath=sse -msse2 -mstackrealign  -c polyiso_powerlaw.c -o polyiso_powerlaw.o
gcc -shared -s -static-libgcc -o polyiso_powerlaw.dll tmp.def polyiso_powerlaw.o -Ld:/rtools44/x86_64-w64-mingw32.static.posix/lib/x64 -Ld:/rtools44/x86_64-w64-mingw32.static.posix/lib -LD:/RCompile/recent/R/bin/x64 -lR
make[1]: Leaving directory '/d/RCompile/CRANincoming/R-devel/polyCub.Rcheck/tests'
make[1]: Entering directory '/d/RCompile/CRANincoming/R-devel/polyCub.Rcheck/tests'
make[1]: Leaving directory '/d/RCompile/CRANincoming/R-devel/polyCub.Rcheck/tests'
make[1]: Entering directory '/d/RCompile/CRANincoming/R-devel/polyCub.Rcheck/tests'
make[1]: Leaving directory '/d/RCompile/CRANincoming/R-devel/polyCub.Rcheck/tests'
> if (shlib_error) {
+     warning("failed to build the shared object/DLL for the polyCub_iso example")
+     q("no")
+ }
> 
> ## load shared object/DLL
> myDLL <- paste0("polyiso_powerlaw", .Platform$dynlib.ext)
> loadNamespace("polyCub")
<environment: namespace:polyCub>
> dyn.load(myDLL)
> 
> ## R function calling C_polyiso_powerlaw
> polyiso_powerlaw <- function (xypoly, logpars, center,
+                               subdivisions = 100L,
+                               rel.tol = .Machine$double.eps^0.25,
+                               abs.tol = rel.tol, stop.on.error = TRUE)
+ {
+     .C("C_polyiso_powerlaw",
+        as.double(xypoly$x), as.double(xypoly$y), as.integer(length(xypoly$x)),
+        as.double(logpars),
+        as.double(center[1L]), as.double(center[2L]),
+        as.integer(subdivisions), as.double(abs.tol), as.double(rel.tol),
+        as.integer(stop.on.error),
+        value = double(1L), abserr = double(1L), neval = integer(1L)
+        )[c("value", "abserr", "neval")]
+ }
> 
> 
> ## example polygon and function parameters
> diamond <- list(x = c(1,2,1,0), y = c(1,2,3,2))
> logpars <- log(c(0.5, 1))
> center <- c(0.5,2.5)  # lies on an edge (to cover that case as well)
> 
> (res <- polyiso_powerlaw(xypoly = diamond,
+                          logpars = logpars,
+                          center = center))
$value
[1] 1.623643

$abserr
[1] 4.190075e-13

$neval
[1] 63

> 
> 
> ## compare with R implementation
> intrfr.powerlaw <- function (R, logpars)
+ {
+     sigma <- exp(logpars[[1L]])
+     d <- exp(logpars[[2L]])
+     if (d == 1) {
+         R - sigma * log(R/sigma + 1)
+     } else if (d == 2) {
+         log(R/sigma + 1) - R/(R+sigma)
+     } else {
+         (R*(R+sigma)^(1-d) - ((R+sigma)^(2-d) - sigma^(2-d))/(2-d)) / (1-d)
+     }
+ }
> (orig <- polyCub:::polyCub1.iso(poly = diamond,
+                                 intrfr = intrfr.powerlaw,
+                                 logpars = logpars,
+                                 center = center))
[1] 1.623643e+00 4.190075e-13
> 
> stopifnot(all.equal(res$value, orig[1L]))
> stopifnot(all.equal(res$abserr, orig[2L]))
> 
> ## microbenchmark::microbenchmark(
> ##     polyCub:::polyCub1.iso(diamond, intrfr.powerlaw, logpars, center=center),
> ##     polyiso_powerlaw(diamond, logpars, center=center),
> ##     times = 1000)
> ## ## 150 mus vs. 20 mus
> 
> dyn.unload(myDLL)
> file.remove(myDLL)
[1] TRUE
> 
> proc.time()
   user  system elapsed 
   0.35    0.04    2.18