diff --git a/DESCRIPTION b/DESCRIPTION index f28e533..3f44819 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -47,10 +47,10 @@ LinkingTo: StanHeaders (>= 2.18.0) SystemRequirements: GNU make Collate: + 'R6_class.R' 'aliases.R' 'check_types.R' 'data.R' - 'utils_R6.R' 'distribution_R6_class.R' 'distribution_continuous.R' 'distribution_discrete.R' diff --git a/NAMESPACE b/NAMESPACE index 4cb733b..eb6f576 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,8 @@ # Generated by roxygen2: do not edit by hand +export(R6.class) +export(R6.interface) +export(R6.interface.implements) export(check_logical) export(check_numeric) export(distribution.binomial) @@ -22,10 +25,7 @@ export(rename_params_cmdstanfile_to_rstan) export(simulate_mixture_of_two_normals) export(stanfit_to_dt) export(stanfit_to_matrix) -export(utils.class) -export(utils.class.interface) -export(utils.class.interface.implements) -export(utils.uniroot.vectorized) +export(uniroot.vectorized) import(Rcpp) import(methods) importFrom(RcppParallel,RcppParallelLibs) diff --git a/R/R6_class.R b/R/R6_class.R new file mode 100644 index 0000000..fd523f1 --- /dev/null +++ b/R/R6_class.R @@ -0,0 +1,357 @@ +# Returns a character vector containing function arguments without a set default +# value set, e.g. +# .get_required_args( function( x, y = 1 ) NULL ) +# returns +# "x", +# but +# .get_required_args( function( x, y ) NULL ) +# returns +# c( "x", "y" ) + +.get_required_args <- function( func ) { + args <- formals( func ) + rArgs <- unlist( lapply( args, function( x ) ifelse( length(x)==1, x == "", FALSE ) ) ) + if( !length( rArgs ) ) # Equivalent to if ( length( rArgs ) == 0 ) + return( c() ) + rArgs <- names( args )[ which( rArgs ) ] + rArgs <- rArgs[ which( rArgs != "..." ) ] + return( rArgs ) +} + + + +################################################################################/ +# R6.class +################################################################################/ +##### NOTE: All derived R6 classes using interfaces in mastiff should include +##### this file via Roxygen using the include tag: #' @include R6_class.R +##### to update the collate field in DESCRIPTION. +##### +##### Typically this is only for safety, but if a derived class is defined with +##### a name alphabetically before R6_util_class.R and included in another file, +##### the collate order might matter, e.g. R6_a_new_class.R might break the +##### collate order if #' @include R6_a_new_class.R is ever used. + +#' Class: R6.class +#' +#' @description R6 object extending [R6::R6Class()] to include interfaces. +#' +#' @inheritParams R6::R6Class +#' @param interfaces An optional list of interfaces implemented for the derived +#' class. +#' +#' @export + +R6.class = function( + classname = NULL, + public = list(), + private = NULL, + active = NULL, + inherit = NULL, + interfaces = list(), + lock_objects = TRUE, + class = TRUE, + portable = TRUE, + lock_class = FALSE, + cloneable = TRUE, + parent_env = parent.frame() +){ + ##############################################################################/ + # Validate that all methods defined on an interface are implemented on derived + # class + # + # iMethod_list: list of methods defined on the interface to validate against + # method_list: list of methods defined on the class to be validated + # iName: name of the interface + # method_type: type of method being validated; used for informative error + # messages + # + # Note: Variable names with prefix i are related to the interface not the + # defined class. + .validate_interface_method_args <- function( method_list, iMethod_list, iName, + error_type = "public method" ){ + # For each method defined on the interface of type `method_type`, check that + # the class defines a method with the same name and the same set of required + # arguments + methNames <- names( method_list ) + for ( iMethod in iMethod_list ){ + if ( !is.null( iMethod ) ){ + for ( iMethName in names( iMethod ) ){ + # clone method must exist on R6 class and does not need to be checked + if ( iMethName == "clone" ) next + + # Check iMethName is defined on class (with any set of arguments) + if ( !( iMethName %in% methNames ) ){ + stop( sprintf( "must implement %s %s on interface %s", + error_type, iMethName, iName)) + } + + # Check required arguments for interface public method + iArgs <- formalArgs( iMethod[[ iMethName ]] ) + r_iArgs <- .get_required_args( iMethod[[ iMethName ]] ) + + # Check required arguments for new class public method + args <- formalArgs( method_list[[ iMethName ]] ) + r_args <- .get_required_args( method_list[[ iMethName ]] ) + + if( length( r_iArgs ) ) { + if( !all( r_iArgs %in% args ) ) + stop( sprintf( "incorrect arguments for %s %s on interface %s", + error_type, iMethName, iName ) ) + } + if( length( r_args ) ) { + if( !all( r_args %in% iArgs ) ) + stop( sprintf( "incorrect arguments for %s %s on interface %s", + error_type, iMethName, iName ) ) + } + } + } + } + return( invisible() ) + } + + # Validate that a pair of interfaces do not require incompatible methods + # + # methodList1: list of methods to validate on interface1 + # methodList2: list of methods to validate on intereface2 + # iName1: name of interface1 + # iName2: name of interface2 + # method_type: type of method being validated; used for informative + # error messages + .validate_interface_methods <- function( methodList1, methodList2, + iName1, iName2, + error_type = "public method" ){ + methShared <- intersect( names( methodList1 ), + names( methodList2 ) ) + for ( methName in methShared ){ + # clone method must exist on R6 class and does not need to be validated + if ( methName == "clone" ) next + + args1 <- formalArgs( methodList1[[ methName ]] ) + args2 <- formalArgs( methodList2[[ methName ]] ) + + if ( length( setdiff( args1, args2 ) ) ) + stop( sprintf( "incompatible arguments for %s %s on interfaces %s and %s", + error_type, methName, + iName1, iName2 ) ) + } + return( invisible() ) + } + ##############################################################################/ + + # check to see an inherited class has been created by R6.class + if( !is.null( inherit ) ){ + if( inherit$inherit != "R6.class.parent" ) + stop( "inherited classes must be created by R6.class (i.e. must inherit R6.class.class)" ) + } else{ + inherit = R6.class.class + } + + # create an environment in the parent_env which just contains the name of the + # inherited generator + envir = new.env( parent = parent_env ) + R6.class.parent = inherit + assign( "R6.class.parent", R6.class.parent, envir = envir ) + + # add interfaces to R6 class + if( !is.list( interfaces ) ) interfaces = list( interfaces ) + if ( !is.null( inherit$private_fields$.INTERNAL_INTERFACES ) ){ + interfaces <- c( inherit$private_fields$.INTERNAL_INTERFACES, + interfaces ) + } + + # if an interface is included multiple times, keep the first instance only + interfaces <- interfaces[ !duplicated( interfaces ) ] + + # if at least 2 interfaces are defined, check that multiple interfaces don't + # define incompatible method signatures + nInterfaces <- length( interfaces ) + if ( nInterfaces >= 2 ){ + for ( idx in 1 : ( nInterfaces - 1 ) ){ + interface1 <- interfaces[[ idx ]] + for ( jdx in 2 : nInterfaces ){ + interface2 <- interfaces[[ jdx ]] + .validate_interface_methods( + methodList1 = c( interface1$public_fields, interface1$public_methods ), + methodList2 = c( interface2$public_fields, interface2$public_methods ), + iName1 = interface1$classname, + iName2 = interface2$classname, + error_type = "public method" + ) + } + } + } + + # if inheriting a class, we need to include all inherited methods + if ( is.null( inherit$public_methods ) ){ + publicMethods <- public + } else { + publicMethods <- utils::modifyList( inherit$public_methods, + public ) + } + + if ( is.null( private ) ) private <- list() + if ( is.null( inherit$private_methods ) ){ + privateMethods <- private + } else { + privateMethods <- utils::modifyList( inherit$private_methods, + private ) + } + + if ( is.null( active ) ) active <- list() + if ( is.null( inherit$active ) ){ + activeMethods <- active + } else { + activeMethods <- utils::modifyList( inherit$active, + active ) + } + + # Check that new class defines all methods specified by all interfaces with + # the correct required arguments + for ( interface in interfaces ){ + if ( interface$inherit != "R6.interface.class") + stop( "Interfaces must be created by R6.interface (i.e. must inherit R6.interface.class" ) + + iName <- interface$classname + + # Validate public methods + .validate_interface_method_args( + method_list = publicMethods, + iMethod_list = list( interface$public_methods, + interface$public_fields ), + iName, + error_type = "public method" + ) + + # Validate private methods + .validate_interface_method_args( + method_list = privateMethods, + iMethod_list = list( interface$private_methods, + interface$private_fields ), + iName, + error_type = "private method" + ) + + # Validate active methods + .validate_interface_method_args( + method_list = activeMethods, + iMethod_list = list( interface$active ), + iName, + error_type = "active field" + ) + } + + # Implicit assumption: If no error has been hit up to this point, all + # interfaces are feasible for derived class and correctly implemented + private$.INTERNAL_INTERFACES <- interfaces + active$interfaces = function() sapply( private$.INTERNAL_INTERFACES, + function( x ) x$classname ) + + return( R6::R6Class( classname = classname, + public = public, + private = private, + active = active, + inherit = R6.class.parent, + lock_objects = lock_objects, + class = class, + portable = portable, + lock_class = lock_class, + cloneable = cloneable, + parent_env = envir ) ) +} + +################################################################################/ +# R6.class.class +# +# add interfaces to R6 class infrastructure +################################################################################/ +R6.class.class = R6::R6Class( + "R6.class.class", + private = list( + .INTERNAL_INTERFACES = c() + ), + active = list( + interfaces = function( val ){ + if( is.null( val ) ){ + return( private$.INTERNAL_INTERFACES ) + } else { + stop( "cannot update interface list manually" ) + } + } + ) +) + +################################################################################/ +# R6.interface.class +# +# add interfaces to R6 class infrastructure +################################################################################/ +R6.interface.class = R6::R6Class( + "R6.interface.class", + public = list( + ############################################################################/ + # is.interface + ############################################################################/ + # @description Logical function indicating whether an object is an + # interface. + is.interface = function() return( TRUE ) + ) +) + +################################################################################/ +# R6.interface +# add interfaces to R6 class infrastructure +################################################################################/ +#' R6.interface +#' +#' Constructor function for an interface for use with [R6.class] +#' +#' @param interfacename Name of the interface. The interface name is useful +#' primarily for S3 method dispatch. +#' @inheritParams R6::R6Class +#' +#' @returns Object of class [R6.interface] +#' +#' @export + +R6.interface = function( + interfacename = NULL, + public = list(), + private = list(), + active = list() +){ + return( R6::R6Class( classname = interfacename, + public = public, + private = private, + active = active, + inherit = R6.interface.class ) ) +} + +################################################################################/ +# R6.class.interface.implements checks to see if an interface has been +# implemented check private internal variable directly to prevent accidental +# name mismatches +################################################################################/ +#' R6.interface.implements +#' +#' @description Checks to see whether interface `interfaceName` has been +#' implemented on object `object`. +#' +#' +#' @param object R6 object of class `R6.class`. +#' @param interfaceName Name of an interface to check for `object`. +#' +#' @export + +R6.interface.implements = function( + object, + interfaceName +){ + if( !R6::is.R6( object ) | !inherits( object, "R6.class.class") ) + stop( "object must be from a class generated by R6.class()" ) + + if( is.null( object$.__enclos_env__$private$.INTERNAL_INTERFACES ) ) + stop( "object must be from a class generated by R6.class()" ) + + return( length( intersect( object$interfaces, interfaceName ) ) == 1 ) +} diff --git a/R/distribution_R6_class.R b/R/distribution_R6_class.R index 47be0eb..40d5c47 100644 --- a/R/distribution_R6_class.R +++ b/R/distribution_R6_class.R @@ -1,17 +1,84 @@ -# Include R6_util_class.R to guarantee utils.class() and utils.class.interface() +# Include R6_util_class.R to guarantee R6.class() and R6.class.interface() # exist when loading the package prior to defining classes -#' @include utils_R6.R +#' @name Mastiff-Distributions +#' @title Distribution Classes +#' +#' @description Distributions implemented as R6 classes in [mastiff] +#' @format NULL +#' @usage NULL +#' +#' @details +#' [mastiff] introduces a R6 class structure which is used to combine the +#' density, distribution function, quantile function and generation of random +#' deviates into a single object. +#' +#' Parameters for a distribution are set at initialisation and can be updated +#' via a named list `$params` stored in the distribution class. +#' +#' Each distribution includes methods +#' \tabular{lll}{ +#' `$d(x)` \tab \tab Evaluates the density at values `x` \cr +#' `$p(q)` \tab \tab Evaluates the distribution function at values `q` \cr +#' `$q(p)` \tab \tab Evaluates the quantile function at values `p` \cr +#' `$r(n)` \tab \tab Generates `n` random values from the distribution \cr +#' `$mean` \tab \tab Returns the mean of the distribution \cr +#' `$sd` \tab \tab Returns the standard deviation of the distribution \cr +#' `$var` \tab \tab Returns the variance of the distribution \cr +#' } +#' +#' @examples +#' # Construct a Poisson( 1 ) random variable +#' Pois_RV <- distribution.poisson( lambda = 1 ) +#' +#' # Evaluate the density, equivalent to dpois( 0 : 5, lambda = 1 ) +#' Pois_RV$d( 0 : 5 ) +#' +#' # Evaluate the distribution function, equivalent to ppois( 0 : 5, lambda = 1 ) +#' Pois_RV$p( 0 : 5 ) +#' +#' # Evaluate the quantile function, equivalent to qpois( c( 0.5, 0.8 ), lambda = 1 ) +#' Pois_RV$q( c( 0.5, 0.8 ) ) +#' +#' # Generate random deviates, equivalent to rpois( 10, lambda = 1 ) +#' Pois_RV$r( 10 ) +#' +#' # Update parameters to a Poisson( 10 ) random variable +#' Pois_RV$params <- list( lambda = 10 ) +#' mean( Pois_RV$r( 1e5 ) ) +#' +#' @section Discrete Distributions: +#' +#' Discrete distributions with class [distribution.discrete.class] +#' \tabular{ll}{ +#' [distribution.binomial] \tab Binomial distribution with size `size` and success probability `prob` \cr +#' [distribution.negative_binomial] \tab Negative Binomial distribution with size `size` and success probability `prob` \cr +#' [distribution.point_mass] \tab Point mass at `value` \cr +#' [distribution.poisson] \tab Poisson distribution with mean `lambda` \cr +#' } +#' +#' @section Continuous Distributions: +#' +#' Discrete distributions with class [distribution.continuous.class] +#' \tabular{ll}{ +#' [distribution.exponential] \tab Exponential distribution with rate `rate` \cr +#' [distribution.gamma] \tab Gamma distribution with shape `shape` and rate `rate` \cr +#' [distribution.normal] \tab Normal distribution with mean `mean` and standard deviation `sd` \cr +#' [distribution.uniform] \tab Uniform distribution on `[min, max]` \cr +#' } +#' +#' @include R6_class.R +NULL ##################################################################/ -# distribution.abstract.class +# distribution.interface ###################################################################/ # Interface for all distributions, enforcing the definition of # - d: density function # - p: distribution function # - q: quantile function # - r: random deviates -distribution.interface <- utils.class.interface( +distribution.interface <- R6.interface( interfacename = "distribution.interface", public = list( ############################################################################ @@ -62,11 +129,14 @@ distribution.interface <- utils.class.interface( #' @field param_names The names of all distribution parameters #' @field params Named list of distribution parameters #' @field interfaces The list of available class interfaces +#' @field mean Mean of the distribution +#' @field sd Standard deviation of the distribution +#' @field var Variance of the distribution -distribution.abstract.class <- utils.class( - "distribution.abstract.class", +distribution.abstract.class <- R6.class( + classname = "distribution.abstract.class", interfaces = list( distribution.interface ), - private = list( + private = list( .name = NULL, # Distribution name .params = list(), # Named list of distribution parameters .param_names = character(), # Character vector of names for params list @@ -115,14 +185,17 @@ distribution.abstract.class <- utils.class( return( private[[ privateType ]][[ param ]] ) } ), - active = list( + active = list( name = function( val ) private$.staticReturn( val, "name" ), param_names = function( val ) private$.staticReturn( val, "param_names" ), params = function( new_val ){ if ( missing( new_val ) ) return( private$.params ) private$.check_params( new_val ) private$.params <- new_val - } + }, + mean = function( val ) stop( "`mean` not implemented on derived class" ), + sd = function( val ) stop( "`sd` not implemented on derived class" ), + var = function( val ) stop( "`var` not implemented on derived class" ) ), public = list( ##############################################################################/ @@ -159,4 +232,19 @@ distribution.abstract.class <- utils.class( r = function( n ) stop( "`r` not implemented on derived class") ) -) \ No newline at end of file +) + +################################################################################/ +# is.distribution +################################################################################/ +#' @title Distribution Classes +#' +#' @description Available distributions implemented in `mastiff`. +#' +#' @param x An R object. +#' +#' `is.distribution( x )` checks where an object `x` inherits from either +#' [distribution.discrete.class] or [distribution.continuous.class] +#' +#' `mastiff` +is.distribution <- function( x ) inherits( x, 'distribution.abstract.class' ) \ No newline at end of file diff --git a/R/distribution_continuous.R b/R/distribution_continuous.R index 7d8db08..c888ae8 100644 --- a/R/distribution_continuous.R +++ b/R/distribution_continuous.R @@ -19,9 +19,9 @@ #' @field support The support of the continuous distribution, i.e. the subset #' of values for which the density is positive, #' -#' @include utils_R6.R +#' @include R6_class.R #' @include distribution_R6_class.R -distribution.continuous.class <- utils.class( +distribution.continuous.class <- R6.class( classname = "distribution.continuous.class", inherit = distribution.abstract.class, private = list( @@ -104,7 +104,7 @@ distribution.continuous.class <- utils.class( density_p_shift <- function( x ){ self$p( transform( x ), log = FALSE ) - p } num_p <- length( p ) - q <- utils.uniroot.vectorized( + q <- uniroot.vectorized( f = density_p_shift, lower = rep( 0, num_p ), upper = rep( 1, num_p ) @@ -144,7 +144,7 @@ distribution.continuous.class <- utils.class( #' \code{[min, max]}. #' @field var The variance of a uniform random variable on \code{[min, #' max]}. -distribution.continuous.uniform.class <- utils.class( +distribution.continuous.uniform.class <- R6.class( classname = "distribution.continuous.uniform.class", inherit = distribution.continuous.class, private = list( @@ -235,7 +235,7 @@ distribution.continuous.uniform.class <- utils.class( ) ) -#' distribution.exponential +#' distribution.uniform #' #' Constructor function for an object of class `distribution.continuous.uniform.class` #' @@ -244,6 +244,7 @@ distribution.continuous.uniform.class <- utils.class( #' #' @returns An object of class [[distribution.continuous.uniform.class]] #' +#' @seealso [Mastiff-Distributions] #' @export distribution.uniform <- function( min = 0, max = 1 ){ distribution.continuous.uniform.class$new( min = min, @@ -273,7 +274,7 @@ distribution.uniform <- function( min = 0, max = 1 ){ #' `$params$rate`. #' @field var The variance of an exponential distribution with rate #' `$params$rate`. -distribution.continuous.exponential.class <- utils.class( +distribution.continuous.exponential.class <- R6.class( classname = "distribution.continuous.exponential.class", inherit = distribution.continuous.class, private = list( @@ -371,6 +372,7 @@ distribution.continuous.exponential.class <- utils.class( #' #' @returns An object of class [[distribution.continuous.exponential.class]] #' +#' @seealso [Mastiff-Distributions] #' @export distribution.exponential <- function( rate = 1 ){ distribution.continuous.exponential.class$new( rate = rate ) @@ -404,7 +406,7 @@ distribution.exponential <- function( rate = 1 ){ #' @field var The variance of a gamma distribution with shape `$params$shape` #' and rate `$params$rate`. -distribution.continuous.gamma.class <- utils.class( +distribution.continuous.gamma.class <- R6.class( classname = "distribution.continuous.gamma.class", inherit = distribution.continuous.class, private = list( @@ -546,6 +548,7 @@ distribution.continuous.gamma.class <- utils.class( #' #' @returns An object of class [[distribution.continuous.gamma.class]] #' +#' @seealso [Mastiff-Distributions] #' @export distribution.gamma <- function( shape, rate, scale ){ if ( missing( rate ) ){ @@ -590,7 +593,7 @@ distribution.gamma <- function( shape, rate, scale ){ #' `$params$rate`. #' @field var The variance of a normal distribution with rate #' `$params$rate`. -distribution.continuous.normal.class <- utils.class( +distribution.continuous.normal.class <- R6.class( classname = "distribution.continuous.normal.class", inherit = distribution.continuous.class, private = list( @@ -693,6 +696,7 @@ distribution.continuous.normal.class <- utils.class( #' #' @returns An object of class [[distribution.continuous.normal.class]] #' +#' @seealso [Mastiff-Distributions] #' @export distribution.normal <- function( mean, sd ){ distribution.continuous.normal.class$new( mean = mean, diff --git a/R/distribution_discrete.R b/R/distribution_discrete.R index efe099c..ce12bbd 100644 --- a/R/distribution_discrete.R +++ b/R/distribution_discrete.R @@ -19,9 +19,10 @@ #' @field support The support of the continuous distribution, i.e. the subset #' of values for which the density is positive, #' -#' @include utils_R6.R +#' @include R6_class.R #' @include distribution_R6_class.R -distribution.discrete.class <- utils.class( +distribution.discrete.class <- +R6.class( classname = "distribution.discrete.class", inherit = distribution.abstract.class, private = list( @@ -148,7 +149,7 @@ distribution.discrete.class <- utils.class( #' `$params$size` and success probability `$params$prob`. #' @field var The variance of a binomial distribution with size #' `$params$size` and success probability `$params$prob`. -distribution.discrete.binomial.class <- utils.class( +distribution.discrete.binomial.class <- R6.class( classname = "distribution.discrete.binomial.class", inherit = distribution.discrete.class, interfaces = list( distribution.interface ), @@ -258,6 +259,7 @@ distribution.discrete.binomial.class <- utils.class( #' #' @returns An object of class [[distribution.discrete.binomial.class]] #' +#' @seealso [Mastiff-Distributions] #' @export distribution.binomial <- function( size, prob ){ @@ -287,7 +289,7 @@ distribution.binomial <- function( size, prob ){ #' `$params$lambda`. #' @field var The variance of a Poisson distribution with mean `$params$lambda`. -distribution.discrete.poisson.class <- utils.class( +distribution.discrete.poisson.class <- R6.class( classname = "distribution.discrete.poisson.class", inherit = distribution.discrete.class, interfaces = list( distribution.interface ), @@ -387,6 +389,7 @@ distribution.discrete.poisson.class <- utils.class( #' #' @returns An object of class [[distribution.discrete.poisson.class]] #' +#' @seealso [Mastiff-Distributions] #' @export distribution.poisson <- function( lambda ){ @@ -422,7 +425,7 @@ distribution.poisson <- function( lambda ){ #' `$params$lambda`. #' @field var The variance of a negative_binomial distribution with mean `$params$lambda`. -distribution.discrete.negative_binomial.class <- utils.class( +distribution.discrete.negative_binomial.class <- R6.class( classname = "distribution.discrete.negative_binomial.class", inherit = distribution.discrete.class, interfaces = list( distribution.interface ), @@ -564,6 +567,7 @@ distribution.discrete.negative_binomial.class <- utils.class( #' #' @returns An object of class [[distribution.discrete.negative_binomial.class]] #' +#' @seealso [Mastiff-Distributions] #' @export distribution.negative_binomial <- function( size, prob, mu ){ @@ -600,7 +604,7 @@ distribution.negative_binomial <- function( size, prob, mu ){ #' @field mean The mean of a point mass at `$params$value`. #' @field sd The standard deviation of a point mass at `$params$value`. #' @field var The variance of a point mass at `$params$value`. -distribution.discrete.point_mass.class <- utils.class( +distribution.discrete.point_mass.class <- R6.class( classname = "distribution.discrete.point_mass.class", inherit = distribution.discrete.class, interfaces = list( distribution.interface ), @@ -718,6 +722,7 @@ distribution.discrete.point_mass.class <- utils.class( #' #' @returns An object of class [[distribution.discrete.point_mass.class]] #' +#' @seealso [Mastiff-Distributions] #' @export distribution.point_mass <- function( value ){ diff --git a/R/utils.R b/R/utils.R index a4e2ceb..003069a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,5 +1,5 @@ ###################################################################/ -# Name: utils.uniroot.vectorized +# Name: uniroot.vectorized # Description: vectorized version of the Brent Root algorithm # useful for when solving many similar optimization problems # where evaluation of the objective can be calculated far more @@ -30,11 +30,11 @@ #' f <- function( x ) ( x^2 - 1 ) * ( x^2 - 2 ) #' lower <- c( -2, -1.2, 0, 1.2 ) #' upper <- c( -1.2, 0, 1.2, 2 ) -#' utils.uniroot.vectorized( f, lower, upper ) +#' uniroot.vectorized( f, lower, upper ) #' #' @export -utils.uniroot.vectorized = function( f, lower, upper, tol = 1e-8, itmax = 100, eps = 1e-10 ){ +uniroot.vectorized = function( f, lower, upper, tol = 1e-8, itmax = 100, eps = 1e-10 ){ # check the initial bracket f_lower <- f( lower ) f_upper <- f( upper ) @@ -100,7 +100,7 @@ utils.uniroot.vectorized = function( f, lower, upper, tol = 1e-8, itmax = 100, e } ###################################################################/ -# Name: utils.optimise.vectorized +# Name: optimise.vectorized # Description: vectorized version of the Brent Minimisation algorithm # useful for when solving many similar optimization problems # where evaluation of the objective can be calculated far more @@ -112,7 +112,7 @@ utils.uniroot.vectorized = function( f, lower, upper, tol = 1e-8, itmax = 100, e # Return: TRUE/FALSE # Author: Rob Hinch ###################################################################/ -utils.optimise.vectorized = function( f, a, v, b, tol = 1e-6, maximum = F, itmax = 100 ) +optimise.vectorized = function( f, a, v, b, tol = 1e-6, maximum = F, itmax = 100 ) { # constants cgold = 0.3819660 diff --git a/R/utils_R6.R b/R/utils_R6.R deleted file mode 100644 index d76158c..0000000 --- a/R/utils_R6.R +++ /dev/null @@ -1,293 +0,0 @@ -# Returns a character vector containing function arguments without a set default -# value set, e.g. -# .get_required_args( function( x, y = 1 ) NULL ) -# returns -# "x", -# but -# .get_required_args( function( x, y ) NULL ) -# returns -# c( "x", "y" ) - -.get_required_args <- function( func ) { - args <- formals( func ) - rArgs <- unlist( lapply( args, function( x ) ifelse( length(x)==1, x == "", FALSE ) ) ) - if( !length( rArgs ) ) # Equivalent to if ( length( rArgs ) == 0 ) - return( c() ) - rArgs <- names( args )[ which( rArgs ) ] - rArgs <- rArgs[ which( rArgs != "..." ) ] - return( rArgs ) -} - - -# Helper function to validate that all methods of type `method_type` defined on -# the interface are defined correctly on the class -# -# @param iMethod_list list of methods defined on the interface to validate -# against -# @param method_list list of methods defined on the class to be validated -# @param iName name of the interface contributing methods iMethod_list -# @param method_type type of method being validated; used for informative -# error messages -# -# Variable names with prefix i are related to the interface not the defined -# class. - -.validate_interface_methods <- function( method_list, iMethod_list, iName, - error_type = "public method" ){ - # For each method defined on the interface of type `method_type`, check that - # the class defines a method with the same name and the same set of required - # arguments - methNames <- names( method_list ) - for ( iMethod in iMethod_list ){ - if ( !is.null( iMethod ) ){ - for ( iMethName in names( iMethod ) ){ - # clone method must exist on R6 class and does not need to be checked - if ( iMethName == "clone" ) next - - # Check iMethName is defined on class (with any set of arguments) - if ( !( iMethName %in% methNames ) ){ - stop( sprintf( "must implement %s %s on interface %s", - error_type, iMethName, iName)) - } - - # Check required arguments for interface public method - iArgs <- formalArgs( iMethod[[ iMethName ]] ) - r_iArgs <- .get_required_args( iMethod[[ iMethName ]] ) - - # Check required arguments for new class public method - args <- formalArgs( method_list[[ iMethName ]] ) - r_args <- .get_required_args( method_list[[ iMethName ]] ) - - if( length( r_iArgs ) ) { - if( !all( r_iArgs %in% args ) ) - stop( sprintf( "incorrect arguments for %s %s on interface %s", - error_type, iMethName, iName ) ) - } - if( length( r_args ) ) { - if( !all( r_args %in% iArgs ) ) - stop( sprintf( "incorrect arguments for %s %s on interface %s", - error_type, iMethName, iName ) ) - } - } - } - } -} - -################################################################################/ -# utils.class -# -# Author: Rob Hinch -################################################################################/ -##### NOTE: All derived R6 classes using interfaces in mastiff should include -##### this file via Roxygen using the include tag: #' @include R6_util_class.R -##### to update the collate field in DESCRIPTION. -##### -##### Typically this is only for safety, but if a derived class is defined with -##### a name alphabetically before R6_util_class.R and included in another file, -##### the collate order might matter, e.g. R6_a_new_class.R might break the -##### collate order if #' @include R6_a_new_class.R is ever used. - -#' Class: utils.class -#' -#' @description R6 object extending [R6::R6Class()] to include interfaces. -#' -#' @inheritParams R6::R6Class -#' @param interfaces An optional list of interfaces implemented for the derived -#' class. -#' -#' @export - -utils.class = function( - classname = NULL, - public = list(), - private = list(), - active = list(), - inherit = NULL, - interfaces = list(), - lock_objects = TRUE, - class = TRUE, - portable = TRUE, - lock_class = FALSE, - cloneable = TRUE, - parent_env = parent.frame() -){ - # check to see an inherited class has been created by utils.class - if( !is.null( inherit ) ){ - if( inherit$inherit != "utils.class.parent" ) - stop( "inherited classes must be created by utils.class (i.e. must inherit utils.class.class)" ) - } else{ - inherit = utils.class.class - } - - # create an environment in the parent_env which just contains the name of the - # inherited generator - envir = new.env( parent = parent_env ) - utils.class.parent = inherit - assign( "utils.class.parent", utils.class.parent, envir = envir ) - - # add interfaces to R6 class - if( !is.list( interfaces ) ) interfaces = list( interfaces ) - - # if inheriting a class, we need to include all the inherited methods - publicMethods <- public - privateMethods <- private - activeMethods <- active - if( !is.null( inherit$public_methods ) ) - publicMethods <- utils::modifyList( inherit$public_methods, publicMethods ) - if( !is.null( inherit$private_methods ) ) - privateMethods <- utils::modifyList( inherit$private_methods, privateMethods ) - if( !is.null( inherit$active ) ) - activeMethods <- utils::modifyList( inherit$active, activeMethods ) - - interfaceNames = c() - nInterfaces = length( interfaces ) - if( nInterfaces ){ - for( k in 1:nInterfaces ){ - if( interfaces[[ k ]]$inherit != "utils.class.interface.class" ) - stop( "interfaces must be created by utils.class.interface (i.e. must inherit utils.class.interface.class" ) - - iName = interfaces[[ k ]]$classname - - # Validate public methods - .validate_interface_methods( - method_list = publicMethods, - iMethod_list = list( interfaces[[ k ]]$public_methods, - interfaces[[ k ]]$public_fields ), - iName, - error_type = "public method" - ) - - # Validate private methods - .validate_interface_methods( - method_list = privateMethods, - iMethod_list = list( interfaces[[ k ]]$private_methods, - interfaces[[ k ]]$private_fields ), - iName, - error_type = "private method" - ) - - # Validate active methods - .validate_interface_methods( - method_list = activeMethods, - iMethod_list = list( interfaces[[ k ]]$active ), - iName, - error_type = "active field" - ) - - interfaceNames[ length( interfaceNames ) + 1 ] = iName - } - } - private$.INTERNAL_INTERFACES = c( inherit$private_fields$.INTERNAL_INTERFACES, interfaceNames ) - active$interfaces = function() return( private$.INTERNAL_INTERFACES ) - - return( R6::R6Class( classname = classname, - public = public, - private = private, - active = active, - inherit = utils.class.parent, - lock_objects = lock_objects, - class = class, - portable = portable, - lock_class = lock_class, - cloneable = cloneable, - parent_env = envir ) ) -} - -################################################################################/ -# utils.class.class -# -# add interfaces to R6 class infrastructure -################################################################################/ -utils.class.class = R6::R6Class( - "utils.class.class", - private = list( - .INTERNAL_INTERFACES = c() - ), - active = list( - interfaces = function( val ){ - if( is.null( val ) ){ - return( private$.INTERNAL_INTERFACES ) - } else { - stop( "cannot update interface list manually" ) - } - } - ) -) - -################################################################################/ -# utils.class.interface.class -# -# add interfaces to R6 class infrastructure -################################################################################/ -#' Class: `utils.class.interface.class` -#' -#' @description R6 class acting as base interface class. - -utils.class.interface.class = R6::R6Class( - "utils.class.interface.class", - public = list( - ############################################################################/ - # is.interface - ############################################################################/ - #' @description Logical function indicating whether an object is an - #' interface. - is.interface = function() return( TRUE ) - ) -) - -################################################################################/ -# utils.class.interface -# add interfaces to R6 class infrastructure -################################################################################/ -#' utils.class.interface -#' -#' Constructor function for objects of class [utils.class.interface.class] -#' -#' @param interfacename Name of the interface. The interface name is useful -#' primarily for S3 method dispatch. -#' @inheritParams R6::R6Class -#' -#' @export - -utils.class.interface = function( - interfacename = NULL, - public = list(), - private = list(), - active = list() -) -{ - return( R6::R6Class( interfacename, - public = public, - private = private, - active = active, - inherit = utils.class.interface.class ) ) -} - -################################################################################/ -# utils.class.interface.implements -# checks to see if an interface has been implemented -# check private internal variable directly to prevent accidental name mismatches -################################################################################/ -#' utils.class.interface.implements -#' -#' @description Checks to see whether interface `interfaceName` has been -#' implemented on object `object`. -#' -#' -#' @param object R6 object of class `utils.class`. -#' @param interfaceName Name of an interface to check for `object`. -#' -#' @export - -utils.class.interface.implements = function( - object, - interfaceName -){ - if( !R6::is.R6( object ) | !inherits( object, "utils.class.class") ) - stop( "object must be from a class generated by utils.class()" ) - - if( is.null( object$.__enclos_env__$private$.INTERNAL_INTERFACES ) ) - stop( "object must be from a class generated by utils.class()" ) - - return( length( intersect( object$.__enclos_env__$private$.INTERNAL_INTERFACES, interfaceName ) ) == 1 ) -} diff --git a/man/Mastiff-Distributions.Rd b/man/Mastiff-Distributions.Rd new file mode 100644 index 0000000..cff90e6 --- /dev/null +++ b/man/Mastiff-Distributions.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distribution_R6_class.R +\name{Mastiff-Distributions} +\alias{Mastiff-Distributions} +\title{Distribution Classes} +\description{ +Distributions implemented as R6 classes in \link{mastiff} +} +\details{ +\link{mastiff} introduces a R6 class structure which is used to combine the +density, distribution function, quantile function and generation of random +deviates into a single object. + +Parameters for a distribution are set at initialisation and can be updated +via a named list \verb{$params} stored in the distribution class. + +Each distribution includes methods +\tabular{lll}{ +\verb{$d(x)} \tab \tab Evaluates the density at values \code{x} \cr +\verb{$p(q)} \tab \tab Evaluates the distribution function at values \code{q} \cr +\verb{$q(p)} \tab \tab Evaluates the quantile function at values \code{p} \cr +\verb{$r(n)} \tab \tab Generates \code{n} random values from the distribution \cr +\verb{$mean} \tab \tab Returns the mean of the distribution \cr +\verb{$sd} \tab \tab Returns the standard deviation of the distribution \cr +\verb{$var} \tab \tab Returns the variance of the distribution \cr +} +} +\section{Discrete Distributions}{ + + +Discrete distributions with class \link{distribution.discrete.class} +\tabular{ll}{ +\link{distribution.binomial} \tab Binomial distribution with size \code{size} and success probability \code{prob} \cr +\link{distribution.negative_binomial} \tab Negative Binomial distribution with size \code{size} and success probability \code{prob} \cr +\link{distribution.point_mass} \tab Point mass at \code{value} \cr +\link{distribution.poisson} \tab Poisson distribution with mean \code{lambda} \cr +} +} + +\section{Continuous Distributions}{ + + +Discrete distributions with class \link{distribution.continuous.class} +\tabular{ll}{ +\link{distribution.exponential} \tab Exponential distribution with rate \code{rate} \cr +\link{distribution.gamma} \tab Gamma distribution with shape \code{shape} and rate \code{rate} \cr +\link{distribution.normal} \tab Normal distribution with mean \code{mean} and standard deviation \code{sd} \cr +\link{distribution.uniform} \tab Uniform distribution on \verb{[min, max]} \cr +} +} + +\examples{ +# Construct a Poisson( 1 ) random variable +Pois_RV <- distribution.poisson( lambda = 1 ) + +# Evaluate the density, equivalent to dpois( 0 : 5, lambda = 1 ) +Pois_RV$d( 0 : 5 ) + +# Evaluate the distribution function, equivalent to ppois( 0 : 5, lambda = 1 ) +Pois_RV$p( 0 : 5 ) + +# Evaluate the quantile function, equivalent to qpois( c( 0.5, 0.8 ), lambda = 1 ) +Pois_RV$q( c( 0.5, 0.8 ) ) + +# Generate random deviates, equivalent to rpois( 10, lambda = 1 ) +Pois_RV$r( 10 ) + +# Update parameters to a Poisson( 10 ) random variable +Pois_RV$params <- list( lambda = 10 ) +mean( Pois_RV$r( 1e5 ) ) + +} diff --git a/man/utils.class.Rd b/man/R6.class.Rd similarity index 93% rename from man/utils.class.Rd rename to man/R6.class.Rd index 7d984c3..f9d6a04 100644 --- a/man/utils.class.Rd +++ b/man/R6.class.Rd @@ -1,14 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_R6.R -\name{utils.class} -\alias{utils.class} -\title{Class: utils.class} +% Please edit documentation in R/R6_class.R +\name{R6.class} +\alias{R6.class} +\title{Class: R6.class} \usage{ -utils.class( +R6.class( classname = NULL, public = list(), - private = list(), - active = list(), + private = NULL, + active = NULL, inherit = NULL, interfaces = list(), lock_objects = TRUE, diff --git a/man/utils.class.interface.Rd b/man/R6.interface.Rd similarity index 69% rename from man/utils.class.interface.Rd rename to man/R6.interface.Rd index 0f5f6ff..be4c353 100644 --- a/man/utils.class.interface.Rd +++ b/man/R6.interface.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_R6.R -\name{utils.class.interface} -\alias{utils.class.interface} -\title{utils.class.interface} +% Please edit documentation in R/R6_class.R +\name{R6.interface} +\alias{R6.interface} +\title{R6.interface} \usage{ -utils.class.interface( +R6.interface( interfacename = NULL, public = list(), private = list(), @@ -23,6 +23,9 @@ and non-functions.} \item{active}{An optional list of active binding functions.} } +\value{ +Object of class \link{R6.interface} +} \description{ -Constructor function for objects of class \link{utils.class.interface.class} +Constructor function for an interface for use with \link{R6.class} } diff --git a/man/R6.interface.implements.Rd b/man/R6.interface.implements.Rd new file mode 100644 index 0000000..8bff86b --- /dev/null +++ b/man/R6.interface.implements.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/R6_class.R +\name{R6.interface.implements} +\alias{R6.interface.implements} +\title{R6.interface.implements} +\usage{ +R6.interface.implements(object, interfaceName) +} +\arguments{ +\item{object}{R6 object of class \code{R6.class}.} + +\item{interfaceName}{Name of an interface to check for \code{object}.} +} +\description{ +Checks to see whether interface \code{interfaceName} has been +implemented on object \code{object}. +} diff --git a/man/distribution.abstract.class.Rd b/man/distribution.abstract.class.Rd index 6c9c196..9df5f35 100644 --- a/man/distribution.abstract.class.Rd +++ b/man/distribution.abstract.class.Rd @@ -7,7 +7,7 @@ Base class for derived distributions } \section{Super class}{ -\code{mastiff::utils.class.class} -> \code{distribution.abstract.class} +\code{mastiff::R6.class.class} -> \code{distribution.abstract.class} } \section{Active bindings}{ \if{html}{\out{
}} @@ -19,6 +19,12 @@ Base class for derived distributions \item{\code{params}}{Named list of distribution parameters} \item{\code{interfaces}}{The list of available class interfaces} + +\item{\code{mean}}{Mean of the distribution} + +\item{\code{sd}}{Standard deviation of the distribution} + +\item{\code{var}}{Variance of the distribution} } \if{html}{\out{
}} } diff --git a/man/distribution.binomial.Rd b/man/distribution.binomial.Rd index 40137da..f9f42d0 100644 --- a/man/distribution.binomial.Rd +++ b/man/distribution.binomial.Rd @@ -17,3 +17,6 @@ An object of class [\link{distribution.discrete.binomial.class}] \description{ Constructor function for an object of class [\link{distribution.discrete.binomial.class}] } +\seealso{ +\link{Mastiff-Distributions} +} diff --git a/man/distribution.continuous.class.Rd b/man/distribution.continuous.class.Rd index a95fc6c..d61e14c 100644 --- a/man/distribution.continuous.class.Rd +++ b/man/distribution.continuous.class.Rd @@ -7,7 +7,7 @@ Base class for univariate continuous distributions } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{distribution.continuous.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{distribution.continuous.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.continuous.exponential.class.Rd b/man/distribution.continuous.exponential.class.Rd index 5c47549..283b7fb 100644 --- a/man/distribution.continuous.exponential.class.Rd +++ b/man/distribution.continuous.exponential.class.Rd @@ -7,7 +7,7 @@ Derived class for an exponentially-distributed random variable. } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.continuous.class]{mastiff::distribution.continuous.class}} -> \code{distribution.continuous.exponential.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.continuous.class]{mastiff::distribution.continuous.class}} -> \code{distribution.continuous.exponential.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.continuous.gamma.class.Rd b/man/distribution.continuous.gamma.class.Rd index c59b9c1..c3d0ebf 100644 --- a/man/distribution.continuous.gamma.class.Rd +++ b/man/distribution.continuous.gamma.class.Rd @@ -7,7 +7,7 @@ Derived class for a gamma-distributed random variable. } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.continuous.class]{mastiff::distribution.continuous.class}} -> \code{distribution.continuous.gamma.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.continuous.class]{mastiff::distribution.continuous.class}} -> \code{distribution.continuous.gamma.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.continuous.normal.class.Rd b/man/distribution.continuous.normal.class.Rd index a38fadf..56a141a 100644 --- a/man/distribution.continuous.normal.class.Rd +++ b/man/distribution.continuous.normal.class.Rd @@ -7,7 +7,7 @@ Derived class for a normally-distributed random variable. } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.continuous.class]{mastiff::distribution.continuous.class}} -> \code{distribution.continuous.normal.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.continuous.class]{mastiff::distribution.continuous.class}} -> \code{distribution.continuous.normal.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.continuous.uniform.class.Rd b/man/distribution.continuous.uniform.class.Rd index 5f97bda..79c5334 100644 --- a/man/distribution.continuous.uniform.class.Rd +++ b/man/distribution.continuous.uniform.class.Rd @@ -7,7 +7,7 @@ Derived class for an uniformly-distributed random variable on \code{[min, max]} } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.continuous.class]{mastiff::distribution.continuous.class}} -> \code{distribution.continuous.uniform.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.continuous.class]{mastiff::distribution.continuous.class}} -> \code{distribution.continuous.uniform.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.discrete.binomial.class.Rd b/man/distribution.discrete.binomial.class.Rd index e9dd659..c39672c 100644 --- a/man/distribution.discrete.binomial.class.Rd +++ b/man/distribution.discrete.binomial.class.Rd @@ -7,7 +7,7 @@ Derived class for an binomially-distributed random variable. } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.discrete.class]{mastiff::distribution.discrete.class}} -> \code{distribution.discrete.binomial.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.discrete.class]{mastiff::distribution.discrete.class}} -> \code{distribution.discrete.binomial.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.discrete.class.Rd b/man/distribution.discrete.class.Rd index 0f370bd..228710a 100644 --- a/man/distribution.discrete.class.Rd +++ b/man/distribution.discrete.class.Rd @@ -7,7 +7,7 @@ Base class for univariate discrete distributions } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{distribution.discrete.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{distribution.discrete.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.discrete.negative_binomial.class.Rd b/man/distribution.discrete.negative_binomial.class.Rd index 48cca37..a88820d 100644 --- a/man/distribution.discrete.negative_binomial.class.Rd +++ b/man/distribution.discrete.negative_binomial.class.Rd @@ -8,7 +8,7 @@ Derived class for an negative binomially-distributed random variable. } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.discrete.class]{mastiff::distribution.discrete.class}} -> \code{distribution.discrete.negative_binomial.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.discrete.class]{mastiff::distribution.discrete.class}} -> \code{distribution.discrete.negative_binomial.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.discrete.point_mass.class.Rd b/man/distribution.discrete.point_mass.class.Rd index f30c34e..a774d68 100644 --- a/man/distribution.discrete.point_mass.class.Rd +++ b/man/distribution.discrete.point_mass.class.Rd @@ -7,7 +7,7 @@ Derived class for a point mass at \verb{$params$value} } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.discrete.class]{mastiff::distribution.discrete.class}} -> \code{distribution.discrete.point_mass.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.discrete.class]{mastiff::distribution.discrete.class}} -> \code{distribution.discrete.point_mass.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.discrete.poisson.class.Rd b/man/distribution.discrete.poisson.class.Rd index 50e594b..10757b7 100644 --- a/man/distribution.discrete.poisson.class.Rd +++ b/man/distribution.discrete.poisson.class.Rd @@ -7,7 +7,7 @@ Derived class for an Poisson-distributed random variable. } \section{Super classes}{ -\code{mastiff::utils.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.discrete.class]{mastiff::distribution.discrete.class}} -> \code{distribution.discrete.poisson.class} +\code{mastiff::R6.class.class} -> \code{\link[mastiff:distribution.abstract.class]{mastiff::distribution.abstract.class}} -> \code{\link[mastiff:distribution.discrete.class]{mastiff::distribution.discrete.class}} -> \code{distribution.discrete.poisson.class} } \section{Active bindings}{ \if{html}{\out{
}} diff --git a/man/distribution.exponential.Rd b/man/distribution.exponential.Rd index 3318a5d..ad2e5df 100644 --- a/man/distribution.exponential.Rd +++ b/man/distribution.exponential.Rd @@ -15,3 +15,6 @@ An object of class [\link{distribution.continuous.exponential.class}] \description{ Constructor function for an object of class \code{distribution.continuous.exponential.class} } +\seealso{ +\link{Mastiff-Distributions} +} diff --git a/man/distribution.gamma.Rd b/man/distribution.gamma.Rd index 057bb13..ab48b7d 100644 --- a/man/distribution.gamma.Rd +++ b/man/distribution.gamma.Rd @@ -19,3 +19,6 @@ An object of class [\link{distribution.continuous.gamma.class}] \description{ Constructor function for an object of class \code{distribution.continuous.gamma.class} } +\seealso{ +\link{Mastiff-Distributions} +} diff --git a/man/distribution.negative_binomial.Rd b/man/distribution.negative_binomial.Rd index 4f52530..f4a2081 100644 --- a/man/distribution.negative_binomial.Rd +++ b/man/distribution.negative_binomial.Rd @@ -21,3 +21,6 @@ An object of class [\link{distribution.discrete.negative_binomial.class}] \description{ Constructor function for an object of class [\link{distribution.discrete.negative_binomial.class}] } +\seealso{ +\link{Mastiff-Distributions} +} diff --git a/man/distribution.normal.Rd b/man/distribution.normal.Rd index 60f926a..e50890e 100644 --- a/man/distribution.normal.Rd +++ b/man/distribution.normal.Rd @@ -17,3 +17,6 @@ An object of class [\link{distribution.continuous.normal.class}] \description{ Constructor function for an object of class \code{distribution.continuous.normal.class} } +\seealso{ +\link{Mastiff-Distributions} +} diff --git a/man/distribution.point_mass.Rd b/man/distribution.point_mass.Rd index 3b36cb9..4fbcdc7 100644 --- a/man/distribution.point_mass.Rd +++ b/man/distribution.point_mass.Rd @@ -15,3 +15,6 @@ An object of class [\link{distribution.discrete.point_mass.class}] \description{ Constructor function for an object of class [\link{distribution.discrete.point_mass.class}] } +\seealso{ +\link{Mastiff-Distributions} +} diff --git a/man/distribution.poisson.Rd b/man/distribution.poisson.Rd index 01aae3a..9978ad0 100644 --- a/man/distribution.poisson.Rd +++ b/man/distribution.poisson.Rd @@ -15,3 +15,6 @@ An object of class [\link{distribution.discrete.poisson.class}] \description{ Constructor function for an object of class [\link{distribution.discrete.poisson.class}] } +\seealso{ +\link{Mastiff-Distributions} +} diff --git a/man/distribution.uniform.Rd b/man/distribution.uniform.Rd index 286c8c4..e236bce 100644 --- a/man/distribution.uniform.Rd +++ b/man/distribution.uniform.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/distribution_continuous.R \name{distribution.uniform} \alias{distribution.uniform} -\title{distribution.exponential} +\title{distribution.uniform} \usage{ distribution.uniform(min = 0, max = 1) } @@ -17,3 +17,6 @@ An object of class [\link{distribution.continuous.uniform.class}] \description{ Constructor function for an object of class \code{distribution.continuous.uniform.class} } +\seealso{ +\link{Mastiff-Distributions} +} diff --git a/man/is.distribution.Rd b/man/is.distribution.Rd new file mode 100644 index 0000000..5aed075 --- /dev/null +++ b/man/is.distribution.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distribution_R6_class.R +\name{is.distribution} +\alias{is.distribution} +\title{Distribution Classes} +\usage{ +is.distribution(x) +} +\arguments{ +\item{x}{An R object. + +\code{is.distribution( x )} checks where an object \code{x} inherits from either +\link{distribution.discrete.class} or \link{distribution.continuous.class} + +\code{mastiff}} +} +\description{ +Available distributions implemented in \code{mastiff}. +} diff --git a/man/utils.uniroot.vectorized.Rd b/man/uniroot.vectorized.Rd similarity index 82% rename from man/utils.uniroot.vectorized.Rd rename to man/uniroot.vectorized.Rd index 2dab47b..8cdc2b3 100644 --- a/man/utils.uniroot.vectorized.Rd +++ b/man/uniroot.vectorized.Rd @@ -1,17 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R -\name{utils.uniroot.vectorized} -\alias{utils.uniroot.vectorized} +\name{uniroot.vectorized} +\alias{uniroot.vectorized} \title{Vectorised uniroot} \usage{ -utils.uniroot.vectorized( - f, - lower, - upper, - tol = 1e-08, - itmax = 100, - eps = 1e-10 -) +uniroot.vectorized(f, lower, upper, tol = 1e-08, itmax = 100, eps = 1e-10) } \arguments{ \item{f}{the objective function to optimise over. Must take a single vector @@ -39,6 +32,6 @@ be calculated more efficiently when vectorised f <- function( x ) ( x^2 - 1 ) * ( x^2 - 2 ) lower <- c( -2, -1.2, 0, 1.2 ) upper <- c( -1.2, 0, 1.2, 2 ) -utils.uniroot.vectorized( f, lower, upper ) +uniroot.vectorized( f, lower, upper ) } diff --git a/man/utils.class.interface.class.Rd b/man/utils.class.interface.class.Rd deleted file mode 100644 index f198298..0000000 --- a/man/utils.class.interface.class.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_R6.R -\name{utils.class.interface.class} -\alias{utils.class.interface.class} -\title{Class: \code{utils.class.interface.class}} -\description{ -R6 class acting as base interface class. -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-utils.class.interface.class-is.interface}{\code{utils.class.interface.class$is.interface()}} -\item \href{#method-utils.class.interface.class-clone}{\code{utils.class.interface.class$clone()}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-utils.class.interface.class-is.interface}{}}} -\subsection{Method \code{is.interface()}}{ -Logical function indicating whether an object is an -interface. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{utils.class.interface.class$is.interface()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-utils.class.interface.class-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{utils.class.interface.class$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/utils.class.interface.implements.Rd b/man/utils.class.interface.implements.Rd deleted file mode 100644 index 86e6ee3..0000000 --- a/man/utils.class.interface.implements.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_R6.R -\name{utils.class.interface.implements} -\alias{utils.class.interface.implements} -\title{utils.class.interface.implements} -\usage{ -utils.class.interface.implements(object, interfaceName) -} -\arguments{ -\item{object}{R6 object of class \code{utils.class}.} - -\item{interfaceName}{Name of an interface to check for \code{object}.} -} -\description{ -Checks to see whether interface \code{interfaceName} has been -implemented on object \code{object}. -} diff --git a/tests/testthat/test-R6_class.R b/tests/testthat/test-R6_class.R new file mode 100644 index 0000000..d6c848d --- /dev/null +++ b/tests/testthat/test-R6_class.R @@ -0,0 +1,517 @@ +test_that( "Interface and class classnames are correctly assigned", { + interfaceA <- R6.interface( + interfacename = "test_interface", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ) ), + active = list( funcC = function( xC ) return( T ) ) + ) + expect_equal( interfaceA$classname, "test_interface" ) + + classA <- R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ) ), + active = list( funcC = function( xC ) return( T ) ), + interfaces = list( interfaceA ) + ) + expect_equal( classA$classname, "test_class" ) + expect_true( R6.interface.implements( classA$new(), "test_interface" ) ) +}) + +test_that( "A single interface can be passed in without wrapping in a list", { + interfaceA <- R6.interface( + interfacename = "test_interface", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ) ), + active = list( funcC = function( xC ) return( T ) ) + ) + + expect_no_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ) ), + active = list( funcC = function( xC ) return( T ) ), + interfaces = interfaceA + ) + ) +}) + +test_that( "Interface forces class to define all methods on interface", { + interfaceA <- R6.interface( + interfacename = "test_interface", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ) + ) + + # Derived class exactly matches interface + expect_no_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class has additional methods on top of interface requirements + expect_no_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ), + funcE = function( xE ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ), + funcF = function( xF ) return( T ) ), + active = list( funcD = function( xD ) return( T ), + funcG = function( xG ) return( T) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class does not define private method funcA + expect_error( + R6.class( + classname = "test_class", + private = list(), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class does not define public method funcB + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class does not define public method funcC + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class does not define active binding funcD + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list(), + interfaces = list( interfaceA ) + ) + ) +}) + +test_that( "Interface forces function signature of class' methods to contain required arguments", { + interfaceA <- R6.interface( + interfacename = "test_interface", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ) + ) + + # Derived class exactly matches interface + expect_no_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class missing function input on funcA + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function() return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class missing function input xB on funcB + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class is missing argument yB on funcB + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class missing function input on funcC + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function() return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class missing function input on funcD + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function() return( T ) ), + interfaces = list( interfaceA ) + ) + ) +}) + +test_that( "Class may include additional optional arguments compared to interface", { + interfaceA <- R6.interface( + interfacename = "test_interface", + public = list( funcA = function( xA ) return( T ) ) + ) + + # Derived class with optional numeric argument + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( xA, yA = 1 ) return( T ) ), + interfaces = interfaceA + ) + ) + + # Derived class with optional logical argument + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( xA, yA = TRUE ) return( T ) ), + interfaces = interfaceA + ) + ) + + # Derived class with additional required argument + expect_error( + R6.class( + classname = "test_class", + public = list( funcA = function( xA, yA ) return( T ) ), + interfaces = interfaceA + ) + ) +}) + +test_that( "Multiple interfaces can be enforced on a class", { + interfaceA <- R6.interface( + interfacename = "test_interface", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ) + ) + + interfaceB <- R6.interface( + interfacename = "test_interface2", + public = list( funcE = function( xE ) return( T ) ), + ) + + # All methods are fully defined on both interfaces + expect_no_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ), + funcE = function( xE ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA, interfaceB ) + ) + ) + + # Missing public method funcC for interfaceA + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcE = function( xE ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA, interfaceB ) + ) + ) + + # Missing public method funcE for interfaceB + expect_error( + R6.class( + classname = "test_class", + private = list( funcA = function( xA ) return( T ) ), + public = list( funcB = function( xB, yB ) return( T ), + funcC = function( xC ) return( T ) ), + active = list( funcD = function( xD ) return( T ) ), + interfaces = list( interfaceA, interfaceB ) + ) + ) +}) + +test_that( "Incompatible interfaces throw an error", { + # If two interfaces define incompatible function signatures, a class calling + # both interfaces shouldn't be created + interfaceA <- R6.interface( + interfacename = "test_interface", + public = list( funcA = function( xA ) return( T ) ) + ) + + interfaceB <- R6.interface( + interfacename = "test_interface", + public = list( funcA = function( xB ) return( T ) ) + ) + + # Can create class with interfaceA alone or interfaceB alone + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( xA ) return( T ) ), + interface = interfaceA + ) + ) + + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( xB ) return( T ) ), + interface = interfaceB + ) + ) + + # ...but cannot create a class with interfaceA and interfaceB + expect_error( + R6.class( + classname = "test_class", + public = list( funcA = function( xA ) return( T ) ), + interface = list( interfaceA, interfaceB ) + ) + ) +}) + +test_that( "Arguments of class methods can be defined in any order", { + interfaceA <- R6.interface( + interfacename = "test_interface", + public = list( funcA = function( xA, yA ) return( T ) ) + ) + + # funcA arguments in the same order as the interface + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( xA, yA ) return( T ) ), + interfaces = interfaceA + ) + ) + + # funcA arguments in the opposite order to the interface + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( yA, xA ) return( T ) ), + interfaces = interfaceA + ) + ) + + # funcA arguments in the same order as the interface + optional argument + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( xA, yA, zA = 1 ) return( T ) ), + interfaces = interfaceA + ) + ) + + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( xA, zA = 1, yA ) return( T ) ), + interfaces = interfaceA + ) + ) + + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( zA = 1, xA, yA ) return( T ) ), + interfaces = interfaceA + ) + ) + + # funcA arguments in the opposite order to the interface + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( yA, xA, zA = 1 ) return( T ) ), + interfaces = interfaceA + ) + ) + + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( yA, zA = 1, xA ) return( T ) ), + interfaces = interfaceA + ) + ) + + expect_no_error( + R6.class( + classname = "test_class", + public = list( funcA = function( zA = 1, yA, xA ) return( T ) ), + interfaces = interfaceA + ) + ) +}) + +test_that( "Derived classes inherit and check interfaces from parent class", { + interfaceA <- R6.interface( + interfacename = "interfaceA", + public = list( funcA = function( xA ) return( T ) ) + ) + + classA <- R6.class( + classname = "classA", + public = list( funcA = function( xA ) return( T ) ), + interfaces = list( interfaceA ) + ) + + # Derived class correct implements interfaceA + expect_no_error( + R6.class( + classname = "classB", + inherit = classA, + public = list( funcA = function( xA ) return( F ) ) + ) + ) + + expect_false({ + classB <- R6.class( + classname = "classB", + inherit = classA, + public = list( funcA = function( xA ) return( F ) ) + ) + classB$new()$funcA() + }) + + # Derived class inherits public method funcA from classA without redefining + expect_no_error( + R6.class( + classname = "classB", + inherit = classA, + public = list( funcB = function( x ) return( T ) ) + ) + ) + + expect_true({ + classB <- R6.class( + classname = "classB", + inherit = classA, + public = list( funcB = function( x ) return( T ) ) + ) + classB$new()$funcA() + }) + + # Derived class has incorrect signature for funcA + expect_error( + R6.class( + classname = "classB", + inherit = classA, + public = list( funcA = function( x ) return( T ) ) + ) + ) +}) + +test_that( "Derived classes inherit all public methods, private methods and active fields from parent class", { + interfaceA <- R6.interface( + interfacename = "interfaceA", + public = list( funcA = function( xA ) NULL ), + private = list( funcB = function( xB ) NULL ), + active = list( funcC = function( xC ) NULL ) + ) + + expect_no_error( + classA <- R6.class( + classname = "classA", + public = list( funcA = function( xA ) return( T ) ), + private = list( funcB = function( xB ) return( T ) ), + active = list( funcC = function( xC ) return( T ) ), + interfaces = list( interfaceA ) + ) + ) + + # Derived class inherits everything from parent class without adding anything + # new + expect_no_error( + R6.class( + classname = "classB", + inherit = classA + ) + ) + + # Derived class inherits private and active but overwrites public + expect_no_error( + R6.class( + classname = "classB", + inherit = classA, + public = list( funcA = function( xA ) return( xA ) ) + ) + ) + + # Derived class inherits public and active but overwrites private + expect_no_error( + R6.class( + classname = "classB", + inherit = classA, + private = list( funcB = function( xB ) return( xB ) ) + ) + ) + + # Derived class inherits public and private but overwrites active + expect_no_error( + R6.class( + classname = "classB", + inherit = classA, + active = list( funcC = function( xC ) return( xC ) ) + ) + ) +}) diff --git a/tests/testthat/test-R6_distribution.R b/tests/testthat/test-R6_distribution.R index e4b53d8..4a253fd 100644 --- a/tests/testthat/test-R6_distribution.R +++ b/tests/testthat/test-R6_distribution.R @@ -3,7 +3,7 @@ test_that( "distribution.abstract.class can not be created on its own", { }) test_that( "A derived distribution returns errors on all interface functions assuming they are not redefined", { - distribution.test.class <- utils.class( + distribution.test.class <- R6.class( classname = "distribution.test.class", inherit = distribution.abstract.class, private = list(), diff --git a/tests/testthat/test-distribution_continuous.R b/tests/testthat/test-distribution_continuous.R index bc5c3d4..26754fd 100644 --- a/tests/testthat/test-distribution_continuous.R +++ b/tests/testthat/test-distribution_continuous.R @@ -23,7 +23,7 @@ test_that( "Default $p() and $q() return the correct CDF and quantile function o # Finite support -- test with uniform distribution unif_min <- 0 unif_max <- 10 - unif_test_class <- distribution.continuous.uniform.class <- utils.class( + unif_test_class <- distribution.continuous.uniform.class <- R6.class( classname = "distribution.continuous.uniform.class", inherit = distribution.continuous.class, private = list( @@ -45,7 +45,7 @@ test_that( "Default $p() and $q() return the correct CDF and quantile function o # Support [0, Inf) -- test via exponential distribution exp_rate <- 0.1 - exp_test_class <- utils.class( + exp_test_class <- R6.class( classname = "distribution.continuous.tmp.class", inherit = distribution.continuous.class, interfaces = list( distribution.interface ), @@ -69,7 +69,7 @@ test_that( "Default $p() and $q() return the correct CDF and quantile function o # Support (-Inf, Inf) -- test via normal distribution norm_mean <- 0 norm_sd <- 10 - norm_test_class <- utils.class( + norm_test_class <- R6.class( classname = "distribution.continuous.normal.class", inherit = distribution.continuous.class, private = list( @@ -99,7 +99,7 @@ test_that( "Default $p() and $q() return the correct CDF and quantile function o norm_class$p( q, lower.tail = TRUE, log.p = FALSE ), tolerance = tol ) - norm_test_class <- utils.class( + norm_test_class <- R6.class( classname = "distribution.continuous.normal.class", inherit = distribution.continuous.class, private = list( diff --git a/tests/testthat/test-distribution_discrete.R b/tests/testthat/test-distribution_discrete.R index b02b55c..70264d6 100644 --- a/tests/testthat/test-distribution_discrete.R +++ b/tests/testthat/test-distribution_discrete.R @@ -1,7 +1,7 @@ test_that( "Default $p() and $q() return the correct CDF and quantile function on distribution.discrete.class", { # Define a temporary class for binomial distribution with $p() and $r() # defined but not $p() or $q() - partial_discrete.class <- utils.class( + partial_discrete.class <- R6.class( classname = "distribution.discrete.tmp.class", inherit = distribution.discrete.class, interfaces = list( distribution.interface ), diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 1842afe..ffaba89 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -18,7 +18,7 @@ test_that( "utils.uniroot.vectorised() returns the same root as stats::uniroot() interval_lower <- sapply( intervals, min, na.rm = TRUE ) interval_upper <- sapply( intervals, max, na.rm = TRUE ) - mastiff_uniroot <- utils.uniroot.vectorized( + mastiff_uniroot <- uniroot.vectorized( f = test_func, lower = interval_lower, upper = interval_upper, diff --git a/tests/testthat/test-utils_R6.R b/tests/testthat/test-utils_R6.R deleted file mode 100644 index 6122b57..0000000 --- a/tests/testthat/test-utils_R6.R +++ /dev/null @@ -1,194 +0,0 @@ -test_that( "Test interface and class names", { - interfaceA <- utils.class.interface( - interfacename = "test_interface", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcE = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ) - ) - expect_equal( interfaceA$classname, "test_interface" ) - - classA <- utils.class( - classname = "test_class", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x,y ) return( T ), funcE = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ), - interfaces = list( interfaceA ) - ) - - expect_equal( classA$classname, "test_class" ) - expect_equal( utils.class.interface.implements( classA$new(), "test_interface"), TRUE ) -} ) - -test_that( "Test class requires the methods on the interface", { - interfaceA <- utils.class.interface( - interfacename = "test_interface", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcE = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ) - ) - - # Incorrect private method name - expect_error( utils.class( - classname = "test_class", - private = list( funcD = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcE = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ), - interfaces = list( interfaceA ) - ) ) - - # Incorrect public method name - expect_error( utils.class( - classname = "test_class", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcD = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ), - interfaces = list( interfaceA ) - ) ) - - # Incorrect public method funcE signature - expect_error( utils.class( - classname = "test_class", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x ) return( T ), - funcE = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ), - interfaces = list( interfaceA ) - ) ) - - # Missing public method funcE - expect_error( utils.class( - classname = "test_class", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ) ), - active = list( funcC = function( x ) return( T ) ), - interfaces = list( interfaceA ) - ) ) - - # Incorrect active binding name - expect_error( utils.class( - classname = "test_class", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcE = function( x ) return( T ) ), - active = list( funcD = function( x ) return( T ) ), - interfaces = list( interfaceA ) - ) ) -} ) - -test_that( "Test class with 2 interfcaes", { - interfaceA <- utils.class.interface( - interfacename = "test_interface", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcE = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ) - ) - - interfaceB <- utils.class.interface( - interfacename = "test_interface2", - public = list( funcF = function( x ) return( T ) ), - ) - - classF <- utils.class( - classname = "test_class", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcE = function( x ) return( T ), - funcF = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ), - interfaces = list( interfaceA, interfaceB ) - ) - - expect_equal( R6::is.R6Class( classF ), TRUE ) - - # Missing public method funcE for interfaceA - expect_error( - utils.class( - classname = "test_class", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcF = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ), - interfaces = list( interfaceA, interfaceB ) - ) ) - - # Missing public method funcF for interfaceB - expect_error( - utils.class( - classname = "test_class", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcE = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ), - interfaces = list( interfaceA, interfaceB ) - ) ) -}) - -test_that("Test class method arguments can be defined in any order", { - interfaceC <- utils.class.interface( - interfacename = "test_interface3", - public = list( funcH = function( x, y ) return( T ) ), - ) - - # Define method arguments in the same order as interface - expect_no_error( utils.class( - classname = "test_class", - public = list( funcH = function( x, y ) return( T ) ), - interfaces = list( interfaceC ) - ) - ) - - # Define method arguments in different order to interface - expect_no_error( utils.class( - classname = "test_class", - public = list( funcH = function( y, x ) return( T ) ), - interfaces = list( interfaceC ) - ) ) -}) - -test_that("Test class methods match interface arguments exactly", { - interfaceC <- utils.class.interface( - interfacename = "test_interface3", - public = list( funcH = function( x ) return( T ) ), - ) - - # Additional argument y in public method funcH - expect_error( - utils.class( - classname = "test_class", - public = list( funcH = function( x, y ) return( T ) ), - interfaces = list( interfaceC ) - ) - ) - - expect_error( - utils.class( - classname = "test_class", - public = list( funcH = function( ) return( T ) ), - interfaces = list( interfaceC ) - ) - ) -}) - -test_that("Test interface on derived class checks base methods", { - interfaceA <- utils.class.interface( - interfacename = "test_interface", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcE = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ) - ) - - expect_no_error( - utils.class( - classname = "test_class", - private = list( funcA = function( x ) return( T ) ), - public = list( funcB = function( x, y ) return( T ), - funcE = function( x ) return( T ) ), - active = list( funcC = function( x ) return( T ) ) - ) ) -} ) \ No newline at end of file