Add global R object with access to package environments

andrjohns · Jun 1, 2024 · 1ad1a2d · 1ad1a2d
1 parent 37c3f3c
commit 1ad1a2d
Show file tree

Hide file tree

Showing 5 changed files with 40 additions and 4 deletions.
diff --git a/inst/include/cpp11/function.hpp b/inst/include/cpp11/function.hpp
@@ -65,14 +65,14 @@ class package {
   }
   function operator[](const std::string& name) { return operator[](name.c_str()); }
 
- private:
   static SEXP get_namespace(const char* name) {
     if (strcmp(name, "base") == 0) {
       return R_BaseEnv;
     }
     sexp name_sexp = safe[Rf_install](name);
     return safe[Rf_findVarInFrame](R_NamespaceRegistry, name_sexp);
   }
+ private:
 
   SEXP data_;
 };

diff --git a/inst/include/quickjs_helpers.hpp b/inst/include/quickjs_helpers.hpp
@@ -93,6 +93,11 @@ static JSContext* JS_NewCustomContext(JSRuntime *rt) {
       "globalThis.os = os;\n";
   eval_buf(ctx, str, strlen(str), "<input>", JS_EVAL_TYPE_MODULE);
 
+  JSValue global_obj = JS_GetGlobalObject(ctx);
+  JSValue r_obj = quickjsr::create_r_object(ctx);
+  JS_SetPropertyStr(ctx, global_obj, "R", r_obj);
+  JS_FreeValue(ctx, global_obj);
+
   return ctx;
 }
 

diff --git a/inst/include/quickjsr/JS_SEXP.hpp b/inst/include/quickjsr/JS_SEXP.hpp
@@ -49,6 +49,34 @@ namespace quickjsr {
     nullptr,
     &js_renv_exotic_methods
   };
+
+  static JSValue js_r_package(JSContext *ctx, JSValueConst this_val, int argc, JSValueConst *argv) {
+    if (argc != 1) {
+      return JS_ThrowTypeError(ctx, "R.package requires one argument");
+    }
+
+    const char *package_name = JS_ToCString(ctx, argv[0]);
+    JS_FreeCString(ctx, package_name);
+    if (!package_name) {
+        return JS_EXCEPTION;
+    }
+    SEXP pkg = cpp11::package::get_namespace(package_name);
+    return SEXP_to_JSValue(ctx, pkg, true, true);
+  }
+
+  static const JSCFunctionListEntry js_r_funcs[] = {
+    JS_CFUNC_DEF("package", 1, js_r_package),
+  };
+
+  static JSValue create_r_object(JSContext *ctx) {
+    JSValue r_obj = JS_NewObject
+    (ctx);
+    if (JS_IsException(r_obj)) {
+      return r_obj;
+    }
+    JS_SetPropertyFunctionList(ctx, r_obj, js_r_funcs, countof(js_r_funcs));
+    return r_obj;
+  }
 }
 
 #endif
diff --git a/inst/include/quickjsr/SEXP_to_JSValue.hpp b/inst/include/quickjsr/SEXP_to_JSValue.hpp
@@ -160,7 +160,8 @@ namespace quickjsr {
       case NILSXP:
         return JS_UNDEFINED;
       default:
-        cpp11::stop("Unsupported type for conversion to JSValue");
+        cpp11::stop("Conversions for type %s to JSValue are not yet implemented",
+                    Rf_type2char(TYPEOF(x)));
     }
   }
 
@@ -183,8 +184,6 @@ namespace quickjsr {
       }
     }
     return SEXP_to_JSValue(ctx, x, auto_unbox_inp, auto_unbox_curr, 0);
-
-    cpp11::stop("Unsupported type for conversion to JSValue");
   }
 } // namespace quickjsr
 

diff --git a/inst/tinytest/test_JSContext.R b/inst/tinytest/test_JSContext.R
@@ -35,3 +35,7 @@ jsc$source(code = "function env_update(env) { env.a = 10; env.b = 20; }")
 jsc$call("env_update", env)
 expect_equal(env$a, 10)
 expect_equal(env$b, 20)
+
+# Test that JS can call functions in R packages using the R object
+jsc$source(code = "function r_fun_test() { return R.package(\"QuickJSR\")[\"get_tz_offset_seconds\"]() }")
+expect_equal(jsc$call("r_fun_test"), as.POSIXlt(Sys.time())$gmtoff)