v1.93 tests and stan type coercion

- book chapter tests in tests/ directory
- ulam wiser about forcing variables to proper stan types

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: rethinking
 Type: Package
 Title: Statistical Rethinking book package
-Version: 1.92
-Date: 2019-10-25
+Version: 1.93
+Date: 2019-12-09
 Author: Richard McElreath
 Maintainer: Richard McElreath <[email protected]>
 Imports: coda, MASS, mvtnorm, loo, shape

R/ulam-function.R

@@ -400,6 +400,8 @@ ulam <- function( flist , data , pars , pars_omit , start , chains=1 , cores=1 ,
                     if ( i==2 )
                         if ( as.character(f[[1]])=="[" )
                             next # move on to next symbol, bc this already has [ after it
+                    # check if length 1, so a constant that doesn't need [i]
+                    if ( length( data[[ as.character(f[[i]]) ]] )==1 ) next
                     # convert to a nested call
                     f[[i]] <- call( "[" , f[[i]] , quote(i) )
                 }
@@ -594,7 +596,6 @@ ulam <- function( flist , data , pars , pars_omit , start , chains=1 , cores=1 ,
 
     # search expression tree recursively and replace pattern with x
     symbol_gsub <- function( f , pattern , x ) {
-
         for ( i in 1:length(f) ) {
             if ( class( f[[i]] )=="name" ) {
                 # could be pattern
@@ -603,13 +604,11 @@ ulam <- function( flist , data , pars , pars_omit , start , chains=1 , cores=1 ,
                 }
             } else {
                 if ( class( f[[i]] )=="call" || class( f[[i]] )=="(" ) {
-                    # nested structure
-                    # need to drill down
+                    # nested structure - need to drill down
                     f[[i]] <- symbol_gsub( f[[i]] , pattern , x )
                 }
             }
         }#i
-
         return( f )
     }
 
@@ -863,6 +862,20 @@ ulam <- function( flist , data , pars , pars_omit , start , chains=1 , cores=1 ,
                 the_dims <- template$dims[1]
             }
 
+            # check for data vars on right side and check types as well
+            # these are registered further down, but set type now when have template info
+            right <- the_dist[-1]
+            for ( k in 1:length(right) ) {
+                if ( right[k] %in% names(data) ) {
+                    # data so check type
+                    need_type <- template$dims[k+1]
+                    if ( need_type %in% c("real","vector") ) {
+                        if ( class(data[[ right[k] ]]) != "numeric" )
+                            data[[ right[k] ]] <- as.numeric(data[[ right[k] ]])
+                    }
+                }
+            }#k
+
             # store info
             # might be multiple parameters in a vector
             for ( j in 1:length(left_symbol) ) {
@@ -925,6 +938,20 @@ ulam <- function( flist , data , pars , pars_omit , start , chains=1 , cores=1 ,
                 }
                 symbols[[ left_symbol[j] ]] <- register_data_var( left_symbol[j] )
             }
+            # check for data vars on right side and check types as well
+            # these are registered further down, but set type now when have template info
+            right <- the_dist[-1]
+            for ( k in 1:length(right) ) {
+                if ( right[k] %in% names(data) ) {
+                    # data so check type
+                    need_type <- template$dims[k+1]
+                    if ( need_type %in% c("real","vector") ) {
+                        if ( class(data[[ right[k] ]]) != "numeric" )
+                            data[[ right[k] ]] <- as.numeric(data[[ right[k] ]])
+                    }
+                }
+            }#k
+
             # build text for model block
             built <- compose_distibution( left_symbol , flist[[i]] )
             m_model_txt <- concat( m_model_txt , built )

R/utilities.r

@@ -295,3 +295,45 @@ format_show <- function( x , digits ) {
 
 # just for recoding "Yes"/"No" to 1/0
 yn2bin <- function(x) ifelse(is.na(x),NA,ifelse(x %in% c("Yes","yes","Y","y"),1,0))
+
+# function to generate n unique keys of length m that are at least x typos apart
+make_ukey <- function( n , m=5 , x=2 , 
+    # default bag omits easy confusions like l/1, 0/o, s/5
+    bag=c("a","b","c","d","e","f","g","h","j",
+          "k","m","n","p","q","r","u","w","x",
+          "y","z",0,2,3,4,6,7,8,9) ) {
+    y <- rep(NA,n)
+
+    genkey <- function() paste( sample(bag,size=m,replace=TRUE) , collapse="" )
+    keydist <- function( k1 , k2 ) {
+        # compute distance of k1 and k2 in simple differences
+        as.numeric(adist( k1 , k2 ))
+    }
+    checkkey <- function( key , xkeys ) {
+        # check distance of key against all xkeys
+        dists <- sapply( xkeys , function(k) keydist( key , k ) )
+        if ( any( dists < x ) ) {
+            # too close!
+            return(FALSE)
+        } else {
+            return(TRUE)
+        }
+    }
+
+    y[1] <- genkey()
+    for ( i in 2:n ) {
+        good <- FALSE
+        while( !good ) {
+            yn <- genkey()
+            f <- checkkey( yn , y[ !is.na(y) ] )
+            if ( f==TRUE ) {
+                y[i] <- yn
+                good <- TRUE
+            }
+        }#while !good
+    }#i
+
+    return(y)
+}
+
+# table( adist(make_ukey(1e3)) )

man/HMC2.Rd

@@ -1,9 +1,9 @@
 \name{HMC2}
 \alias{HMC2}\alias{HMC_2D_sample}
 %- Also NEED an '\alias' for EACH other topic documented here.
-\title{Compare fit models using WAIC or DIC}
+\title{Functions for simple HMC simulations}
 \description{
-  Returns a table of model comparison statistics, by default focused on WAIC.
+  Conduct simple Hamiltonian Monte Carlo simulations.
 }
 \usage{
 HMC2(U, grad_U, epsilon, L, current_q , ... )

tests/book_chapters/test_chapter03.R

@@ -1,4 +1,5 @@
 # test_dir('rethinking/tests/book_chapters',reporter="summary")
+# test_dir('rethinking/tests/book_chapters',filter="chapter03")
 
 context('chapter 3')
 library(rethinking)

tests/book_chapters/test_chapter04.R

@@ -1,4 +1,5 @@
 # test_dir('rethinking/tests/testthat')
+# test_dir('rethinking/tests/book_chapters',filter="chapter04")
 
 context('chapter 4')
 library(rethinking)

tests/book_chapters/test_chapter05.R

@@ -1,4 +1,5 @@
 # test_dir('rethinking/tests/book_chapters',reporter="summary")
+# test_dir('rethinking/tests/book_chapters',filter="chapter05")
 
 context('chapter 5')
 library(rethinking)

tests/book_chapters/test_chapter06.R

@@ -1,4 +1,5 @@
 # test_dir('rethinking/tests/testthat',reporter="summary")
+# test_dir('rethinking/tests/book_chapters',filter="chapter06")
 
 context('chapter 6')
 library(rethinking)

tests/book_chapters/test_chapter07.R

@@ -1,4 +1,5 @@
 # test_dir('rethinking/tests/book_chapters',reporter="summary")
+# test_dir('rethinking/tests/book_chapters',filter="chapter07")
 
 context('chapter 7')
 library(rethinking)

tests/book_chapters/test_chapter08.R

@@ -1,4 +1,5 @@
 # test_dir('rethinking/tests/book_chapters',reporter="summary")
+# test_dir('rethinking/tests/book_chapters',filter="chapter08")
 
 context('chapter 8')
 library(rethinking)

tests/book_chapters/test_chapter09.R

@@ -1,4 +1,5 @@
 # test_dir('rethinking/tests/book_chapters',reporter="summary")
+# test_dir('rethinking/tests/book_chapters',filter="chapter09")
 
 context('chapter 9')
 library(rethinking)