update of vignettes

.development/ToDo.md

@@ -36,8 +36,8 @@
 - [x] remove J.Rd
 - [ ] update DetailedDocumentation.Rmd
 - [ ] update InformationForPackageAuthors.Rmd
-- [ ] docu code structure R
-- [ ] docu code structure C++
+- [x] docu code structure R
+- [x] docu code structure C++
 
 ## Error handling
 

.development/diff.R

@@ -1,14 +1,16 @@
 library(ast2ast)
 
-
-f <- function(a, b, c) {
-  d <- a + b + c
+f <- function() {
+  a::logical <- TRUE
+  b::integer <- 1
+  c::double <- 3.14
+  d::logical_vector <- c(TRUE, FALSE)
+  e::integer_vector <- c(1L, 2L, 3L)
+  f::double_vector <- c(3.14, 3.5)
 }
-
+library(ast2ast)
 fcpp <- translate(f,
-  types_of_args = c("double", "int", "logical"),
-  data_structures = c("vector", "scalar", "scalar"),
-  handle_inputs = rep("copy", 3),
-  verbose = TRUE,
-  output = "R"
+  verbose = TRUE
 )
+
+fcpp()

.development/install.R

@@ -1,2 +1,2 @@
-setwd("/home/konrad/Documents/")
+setwd("/home/konrad/Documents/GitHub/RProjects/ast2ast_supplement/")
 install.packages("ast2ast", type = "source", repos = NULL)

R/BorrowDeclarations.R

@@ -1,16 +1,20 @@
 borrow_declarations <- function(args, handle_args,
                                 data_types_of_args,
                                 all_vars) {
-  args_orig <- args
-  args <- args[handle_args == "borrow"]
-  data_types_of_args <- data_types_of_args[handle_args == "borrow"]
-  handle_args <- handle_args[handle_args == "borrow"]
-  names <- lapply(args, function(x) {
-    generate_new_name(x, "Input", "_", all_vars)@value
-  })
-  types_of_var <- lapply(data_types_of_args, function(x) {
-    cString("etr::Vec<", x, ", etr::Borrow<", x, ">>", "")@value
+  index <- which(handle_args == "borrow")
+  names <- lapply(seq_along(args), function(x) {
+    if (x %in% index) {
+      generate_new_name(args[x], "Input", "_", all_vars)@value
+    } else {
+      return(args[x])
+    }
   })
+  types_of_var <- Map(function(a, b) {
+    if (b == "borrow") {
+      cString("etr::Vec<", a, ", etr::Borrow<", a, ">>", "")@value
+    }
+  }, data_types_of_args, handle_args)
+
   result <- character(
     length =
       length(types_of_var[!is.null(types_of_var)])
@@ -27,5 +31,5 @@ borrow_declarations <- function(args, handle_args,
     }
   }
   result <- cString(result, "")@value
-  return(list(result, unique(c(names, args_orig))))
+  return(list(result, names))
 }

R/checkVariableTypePairs.R → R/CheckVariableTypePairs.R

@@ -9,7 +9,7 @@ check_variable_type_pairs <- function(args, variable_pair_list) {
   assert(
     "Found a type declaration for an argument to the function.
     It is not allowed to define types more than one time." =
-      !(names %in% args)
+      !any(names %in% args)
   )
   allowed_types <- function() {
     c(
@@ -19,7 +19,7 @@ check_variable_type_pairs <- function(args, variable_pair_list) {
   }
   assert(
     "Unknown type found in variable declaration" =
-      types %in% allowed_types()
+      any(types %in% allowed_types()) || (length(types) == 0)
   )
   unique_names <- unique(names)
   sapply(unique_names, function(x) {

R/codelinesclass.R → R/CodelineClass.R

@@ -17,6 +17,59 @@
 # You should have received a copy of the GNU General Public License along with ast2ast
 # If not see: https://www.gnu.org/licenses/old-licenses/gpl-2.0.html#SEC4
 
+permitted_fcts <- function() {
+  c(
+    "::", "=", "<-", "[", "at", "for", "while", "next", "break", "c", ":",
+    "sin", "asin", "sinh", "cos", "acos", "cosh",
+    "tan", "atan", "tanh", "log", "sqrt",
+    "^", "+", "-", "*", "/",
+    "if", "{", "(",
+    "==", "!=", ">", ">=", "<", "<=", "print", "return",
+    "vector", "matrix", "length", "dim",
+    "exp", "&&", "||", "!",
+    "is.na", "is.infinite", "is.finite",
+    "Rf_ScalarReal", "i2d", "cmr", "cpp2R",
+    "vector_numeric",
+    "vector_logical", "while",
+    "vector_integer", "rep", "get_deriv", "assign",
+    "set_indep", "unset_indep", "power"
+  )
+}
+
+namespace_etr <- function() {
+  c(
+    "coca", "sinus", "asinus", "sinush",
+    "cosinus", "acosinus", "cosinush",
+    "tangens", "atangens", "tangensh",
+    "ln", "sqroot",
+    "print", "vector", "matrix", "length", "dim", "cmr",
+    "exp", "i2d", "at", "exp", "at",
+    "isNA", "isInfinite", "colon", "cpp2R", "rep", "get_deriv",
+    "assign_deriv", "set_indep", "unset_indep", "power"
+  )
+}
+
+generic_fcts <- function() {
+  c(
+    "+", "-",
+    "*", "/", "if", "else if", "else", "{", "(",
+    "==", "!=", ">", ">=", "<", "<=", "vector",
+    "rep", "::",
+    "matrix", "length", "dim", "cmr", "exp", "at",
+    "&&", "||", "Rf_ScalarReal", "cpp2R",
+    "rep", "while", "get_deriv", "assign",
+    "unset_indep", "power"
+  )
+}
+
+math_fcts <- function() {
+  c(
+    "sin", "asin", "sinh", "cos", "acos", "cosh",
+    "tan", "atan", "tanh", "log", "^", "sqrt", "power"
+  )
+}
+
+
 #' @import R6
 LC <- R6::R6Class("LC",
 

R/FunctionLists.R

@@ -1,11 +1,10 @@
 permitted_fcts <- function() {
-  # TODO: remove all RNG functions
   c(
     "::", "=", "<-", "[", "at", "for", "while", "next", "break", "c", ":",
     "sin", "asin", "sinh", "cos", "acos", "cosh",
     "tan", "atan", "tanh", "log", "sqrt",
     "^", "+", "-", "*", "/",
-    "if", "{", "(", # TODO: check whether else if is required
+    "if", "{", "(",
     "==", "!=", ">", ">=", "<", "<=", "print", "return",
     "vector", "matrix", "length", "dim",
     "exp", "&&", "||", "!",

R/node_classes.R → R/NodeClasses.R

@@ -54,7 +54,7 @@ PC <- R6::R6Class("PC",
     },
     replace_int = function() {
       i <- 1
-      while (i < length(self$arguments)) {
+      while (i <= length(self$arguments)) {
         if (is.symbol(self$arguments)) {
           return()
         }

R/SEXPDeclarations.R

@@ -1,33 +1,37 @@
 sexp_declarations <- function(args, handle_args,
                               data_types_of_args,
                               all_vars, types_of_args) {
-  other_args <- args[types_of_args != "SEXP"]
-  args <- args[types_of_args == "SEXP"]
+  index <- which(types_of_args == "SEXP")
 
-  print(args)
-  print(other_args)
-  data_types_of_args <- data_types_of_args[types_of_args == "SEXP"]
-  handle_args <- handle_args[types_of_args == "SEXP"]
-  names <- lapply(args, function(x) {
-    generate_new_name(x, "SEXP", "", all_vars)@value
-  })
-  types_of_var <- Map(function(a, b) {
-    if (a == "borrow") {
-      cString("etr::Vec<", b, ", etr::BorrowSEXP<", b, ">>", "")@value
-    } else if (a == "copy") {
-      cString("etr::Vec<", b, ">", "")@value
+  names <- lapply(seq_along(args), function(x) {
+    if (x %in% index) {
+      return(generate_new_name(args[x], "SEXP", "", all_vars)@value)
     } else {
-      stop("found unknown input of how to handle
+      return(args[x])
+    }
+  })
+  types_of_var <- Map(function(a, b, c) {
+    if (c == "SEXP") {
+      if (a == "borrow") {
+        cString("etr::Vec<", b, ", etr::BorrowSEXP<", b, ">>", "")@value
+      } else if (a == "copy") {
+        cString("etr::Vec<", b, ">", "")@value
+      } else {
+        stop("found unknown input of how to handle
         arguments can be either copy or borrow")
+      }
     }
-  }, handle_args, data_types_of_args)
+  }, handle_args, data_types_of_args, types_of_args)
   result <- character(length = length(names))
   for (i in seq_along(names)) {
-    result[i] <- cString(
-      "\t", types_of_var[[i]], " ", args[[i]], "; ",
-      args[[i]], " = ", names[[i]], ";\n", ""
-    )@value
+    if (!is.null(types_of_var[[i]])) {
+      result[i] <- cString(
+        "\t", types_of_var[[i]], " ", args[[i]], "; ",
+        args[[i]], " = ", names[[i]], ";\n", ""
+      )@value
+    }
   }
   result <- c(result, "\n")
-  return(list(cString(result, "")@value, unique(c(names, other_args))))
+
+  return(list(cString(result, "")@value, names))
 }