R Under development (unstable) (2024-07-01 r86857 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(magrittr) > library(unittest) > > library(gadget3) > > params <- list() > actions <- list() > expecteds <- new.env(parent = emptyenv()) > > # matrix_vec > matrix_vec_tf <- matrix(c(0,1,0,1,0,0,0,0,1), nrow = 3) > matrix_vec_vec <- c(10, 100, 1000) > matrix_vec_out <- rep(0, 5) > actions <- c(actions, ~{ + comment('matrix_vec') + matrix_vec_out <- g3_matrix_vec(matrix_vec_tf, matrix_vec_vec) + REPORT(matrix_vec_out) + }) > expecteds$matrix_vec_out <- c(100, 10, 1000) > > # logspace_add() > logspace_add_1 <- 0.0 > logspace_add_0 <- 0.0 > logspace_inp_1 <- 1.0 > logspace_inp_0 <- 0.0 > actions <- c(actions, ~{ + comment('logspace_add') + # NB: We have to cast "0" to a Type for the below to work, but this happens automatically + logspace_add_1 <- logspace_add(logspace_inp_1, 0) + logspace_add_0 <- logspace_add(logspace_inp_0, logspace_inp_0) + REPORT(logspace_add_1) + REPORT(logspace_add_0) + }) > expecteds$logspace_add_1 <- 1.313262 > expecteds$logspace_add_0 <- 0.6931472 > > # logspace_add_vec() > logspace_add_vec_inp <- c(0,0.1,0.2,0.3) > logspace_add_vec_0 <- c(0,0,0,0) > logspace_add_vec_1 <- c(0,0,0,0) > actions <- c(actions, ~{ + comment('logspace_add_vec') + logspace_add_vec_0 <- logspace_add_vec(logspace_add_vec_inp, 0) + logspace_add_vec_1 <- logspace_add_vec(logspace_add_vec_inp, 1) + REPORT(logspace_add_vec_0) + REPORT(logspace_add_vec_1) + }) > expecteds$logspace_add_vec_0 <- c(0.6931472, 0.7443967, 0.7981389, 0.8543552) > expecteds$logspace_add_vec_1 <- c(1.313262, 1.341154, 1.371101, 1.403186) > > # ratio_add_vec() > ratio_add_vec_inp_orig_vec <- runif(10) * 100 > ratio_add_vec_inp_orig_amount <- floor(runif(10) * 10) > ratio_add_vec_inp_new_vec <- runif(10) * 100 > ratio_add_vec_inp_new_amount <- floor(runif(10) * 10) > ratio_add_vec_output <- rep(0, 10) > actions <- c(actions, ~{ + comment('ratio_add_vec') + ratio_add_vec_output <- ratio_add_vec( + ratio_add_vec_inp_orig_vec, ratio_add_vec_inp_orig_amount, + ratio_add_vec_inp_new_vec, ratio_add_vec_inp_new_amount) + REPORT(ratio_add_vec_output) + }) > ratio_add_vec_total <- ratio_add_vec_inp_orig_amount + ratio_add_vec_inp_new_amount > expecteds$ratio_add_vec_output <- ratio_add_vec_inp_orig_vec * (ratio_add_vec_inp_orig_amount / g3_env$avoid_zero_vec(ratio_add_vec_total)) + + ratio_add_vec_inp_new_vec * (ratio_add_vec_inp_new_amount / g3_env$avoid_zero_vec(ratio_add_vec_total)) > > ############################################################################### > > nll <- 0.0 > actions <- c(actions, ~{ + comment('done') + nll <- nll + g3_param('rv') + return(nll) + }) > params <- list(rv=0) > > # Compile model > model_fn <- g3_to_r(actions, trace = FALSE) > # model_fn <- edit(model_fn) > if (nzchar(Sys.getenv('G3_TEST_TMB'))) { + model_cpp <- g3_to_tmb(actions, trace = FALSE) + # model_cpp <- edit(model_cpp) + model_tmb <- g3_tmb_adfun(model_cpp, params, compile_flags = c("-O0", "-g")) + } else { + writeLines("# skip: not compiling TMB model") + } # skip: not compiling TMB model > > # Compare everything we've been told to compare > result <- model_fn(params) > # str(attributes(result), vec.len = 10000) > for (n in ls(expecteds)) { + ok(ut_cmp_equal( + attr(result, n), + expecteds[[n]], tolerance = 1e-6), n) + } ok - logspace_add_0 ok - logspace_add_1 ok - logspace_add_vec_0 ok - logspace_add_vec_1 ok - matrix_vec_out ok - ratio_add_vec_output > > if (nzchar(Sys.getenv('G3_TEST_TMB'))) { + param_template <- attr(model_cpp, "parameter_template") + param_template$value <- params[param_template$switch] + gadget3:::ut_tmb_r_compare(model_fn, model_tmb, param_template) + } > > proc.time() user system elapsed 0.28 0.07 0.34 # Looks like you passed all 6 tests.