Skip to content

Fix some problematic class comparisons #389

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
MichaelChirico wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Fix some problematic class comparisons #389

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion R/animation_functions.r
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -253,7 +253,7 @@ dagfx_anim_forward <- function( the_dag , Y , X , n_frames , n_loops=3 , path_fr
print(dat)

# organize colors
if ( class(color_list)=="list" ) {
if ( is.list(color_list) ) {
# named list, so sort in order of uvars
color_list <- unlist(color_list)[uvars]
}
Expand Down
4 changes: 2 additions & 2 deletions R/compare.r
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,7 @@ compare <- function( ... , n=1e3 , sort="WAIC" , func=WAIC , WAIC=TRUE , refresh

# use substitute to deparse the func argument
the_func <- func
if ( class(the_func) != "character" )
if ( !is.character(the_func) )
the_func <- deparse(substitute(func))

# check class of fit models and warn when more than one class represented
Expand Down Expand Up @@ -229,7 +229,7 @@ compare_old <- function( ... , nobs=NULL , sort="AICc" , BIC=FALSE , DIC=FALSE ,
pD.list <- rep( NA , length(L) )
for ( i in 1:length(L) ) {
m <- L[[i]]
if ( class(m)=="map" ) {
if ( inherits(m, "map") ) {
post <- sample.qa.posterior( m , n=DICsamples )
message( paste("Computing DIC for model",mnames[i]) )
dev <- sapply( 1:nrow(post) ,
Expand Down
2 changes: 1 addition & 1 deletion R/distributions.r
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -350,7 +350,7 @@ dgnorm <- function( x , mu , alpha , beta , log=FALSE ) {
# categorical distribution for multinomial models

dcategorical <- function( x , prob , log=TRUE ) {
if ( class(prob)=="matrix" ) {
if ( is.matrix(prob) ) {
# vectorized probability matrix
# length of x needs to match nrow(prob)
logp <- sapply( 1:nrow(prob) , function(i) log(prob[i,x[i]]) )
Expand Down
2 changes: 1 addition & 1 deletion R/drawdag.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ drawdag <- function( x , col_arrow="black" , col_segment="black" , col_labels="b
require(dagitty)

# check for list of DAGs
if ( class(x)=="list" ) {
if ( is.list(x) ) {
n <- length(x)
y <- make.grid(n)
par(mfrow=y)
Expand Down
2 changes: 1 addition & 1 deletion R/drawdag_igraph.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -40,7 +40,7 @@ graphdag <- function( x ,
for ( uv in unobs_vars ) the_shapes[ which(the_vars==uv) ] <- "circle"
}
if ( interact==FALSE ) {
if ( class(layout)!="matrix" )
if ( !is.matrix(layout) )
the_layout <- do.call( layout , list(mgraph) )
else
the_layout <- layout
Expand Down
2 changes: 1 addition & 1 deletion R/ensemble.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ ensemble <- function( ... , data , n=1e3 , func=WAIC , weights , refresh=0 , rep
if ( missing(weights) ) {
if ( length(L)>1 ) {
use_func <- func
if ( class(use_func) != "character" )
if ( !is.character(use_func) )
use_func <- deparse(substitute(func))
ictab <- compare( ... , func=use_func , refresh=refresh , n=n , sort=FALSE )
rownames(ictab) <- mnames
Expand Down
14 changes: 7 additions & 7 deletions R/glimmer.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -50,7 +50,7 @@ xparse_glimmer_formula <- function( formula , data ) {
# find fixed effects list by deleting random effects and expanding
f_nobars <- nobars( formula )
# catch implied intercept error -- happens when right side of formula is only () blocks
if ( class(f_nobars)=="name" & length(f_nobars)==1 ) {
if ( is.name(f_nobars) & length(f_nobars)==1 ) {
f_nobars <- nobars( as.formula( paste( deparse(formula) , "+ 1" ) ) )
}
#fixef <- make.names( colnames( model.matrix( f_nobars , data ) ) )
Expand All @@ -62,7 +62,7 @@ xparse_glimmer_formula <- function( formula , data ) {
# mdat <- cbind( data[[outcome_name]] , mdat )
# colnames(mdat)[1] <- outcome_name
outcome <- model.frame( f_nobars , data )[,1]
if ( class(outcome)=="matrix" ) {
if ( is.matrix(outcome) ) {
# fix outcome name
outcome_name <- colnames( outcome )[1]
}
Expand All @@ -81,7 +81,7 @@ xparse_glimmer_formula <- function( formula , data ) {
if ( FALSE ) { # check index variables?
if ( TRUE ) {
# check that grouping vars are class integer
if ( class( data[[name]] )!="integer" ) {
if ( !is.integer( data[[name]] ) ) {
stop( paste( "Grouping variables must be integer type. '" , name , "' is instead of type: " , class( data[[name]] ) , "." , sep="" ) )
}
# check that values are contiguous
Expand All @@ -102,7 +102,7 @@ xparse_glimmer_formula <- function( formula , data ) {

# parse formula
v <- var[[i]][[2]]
if ( class(v)=="numeric" ) {
if ( is.numeric(v) ) {
# just intercept
ranef[[ name ]] <- "(Intercept)"
} else {
Expand Down Expand Up @@ -131,7 +131,7 @@ glimmer <- function( formula , data , family=gaussian , prefix=c("b_","v_") , de

# convert family to text
family.orig <- family
if ( class(family)=="function" ) {
if ( is.function(family) ) {
family <- do.call(family,args=list())
}
link <- family$link
Expand All @@ -155,7 +155,7 @@ glimmer <- function( formula , data , family=gaussian , prefix=c("b_","v_") , de
)

# check input
if ( class(formula)!="formula" ) stop( "Input must be a glmer-style formula." )
if ( !inherits(formula, "formula") ) stop( "Input must be a glmer-style formula." )
if ( missing(data) ) stop( "Need data" )

f <- formula
Expand All @@ -170,7 +170,7 @@ glimmer <- function( formula , data , family=gaussian , prefix=c("b_","v_") , de
# check for size variable in Binomial
dtext <- family_liks[[family]]
if ( family=="binomial" ) {
if ( class(pf$y)=="matrix" ) {
if ( is.matrix(pf$y) ) {
# cbind input
pf$dat[[pf$yname]] <- pf$y[,1]
pf$dat[[concat(pf$yname,"_size")]] <- apply(pf$y,1,sum)
Expand Down
26 changes: 13 additions & 13 deletions R/map-quap.r
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -28,8 +28,8 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
########################################
# check arguments
if ( missing(flist) ) stop( "Formula required." )
if ( class(flist) != "list" ) {
if ( class(flist)=="formula" ) {
if ( !is.list(flist) ) {
if ( inherits(flist, "formula") ) {
flist <- list(flist)
} else {
stop( "Formula or list of formulas required." )
Expand Down Expand Up @@ -137,7 +137,7 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
LHS <- f[[2]]
flag_monad_linear_model <- FALSE
if ( length(RHS)==1 ) {
if ( class(RHS)=="numeric" | class(RHS)=="name" )
if ( is.numeric(RHS) || is.name(RHS) )
flag_monad_linear_model <- TRUE
fname <- ""
} else {
Expand All @@ -152,7 +152,7 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
n_args <- length(RHS)
args_list <- as.list(RHS)
# check for LHS with brackets []
if ( class(LHS)=="call" ) {
if ( is.call(LHS) ) {
if ( as.character(LHS[[1]])=="[" ) {
ival <- suppressWarnings( as.numeric(as.character(LHS[[3]])) )
if ( is.na(ival) ) {
Expand Down Expand Up @@ -222,10 +222,10 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
if ( length(flist) > 1 ) {
flag_flatten <- FALSE
for ( i in 2:length(flist) ) {
if ( !(class(flist[[i]])=="formula") )
if ( !inherits(flist[[i]], "formula") )
stop( "Input not a formula." )
LHS <- flist[[i]][[2]]
if ( class(LHS)=="call" ) {
if ( is.call(LHS) ) {
fname <- as.character(LHS[[1]])
if ( fname=="c" | fname=="[" | fname %in% link.names ) {
if ( fname=="c" ) {
Expand Down Expand Up @@ -279,7 +279,7 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
# loop in reverse order, so linear models lower down get pulled up
for ( i in length(flist2):2 ) {
# linear models are class list
if ( class(flist2[[i]])=="list" ) {
if ( is.list(flist2[[i]]) ) {
LHS <- flist2[[i]][[1]]
RHS <- flist2[[i]][[2]]
# save current likelihood, so can check for link
Expand All @@ -297,7 +297,7 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
if ( i > 2 ) {
# RHSp <- paste( "(" , RHS , ")" , collapse="" )
for ( j in (i-1):2 ) {
if ( class(flist2[[j]])=="list" ) {
if ( is.list(flist2[[j]]) ) {
#flist2[[j]][[2]] <- gsub( LHS , RHSp , flist2[[j]][[2]] )
flist2[[j]][[2]] <- mygrep( LHS , RHS , flist2[[j]][[2]] , add.par=TRUE )
} else {
Expand All @@ -314,7 +314,7 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
flist3 <- list()
j <- 1
for ( i in 1:length(flist2) ) {
if ( class(flist2[[i]]) != "list" ) {
if ( !is.list(flist2[[i]]) ) {
flist3[[j]] <- flist2[[i]]
j <- j + 1
}
Expand Down Expand Up @@ -352,7 +352,7 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
# scan formula for right prior
for ( g in 2:length(flist) ) {
# check for `[`
if ( class(flist[[g]][[2]])=="call" ) {
if ( is.call(flist[[g]][[2]]) ) {
# assume `[`, because other calls should be purged by now
the_par_with_index <- deparse(flist[[g]][[2]])
the_par <- as.character( flist[[g]][[2]][[2]] )
Expand All @@ -368,7 +368,7 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
# get length of vector by scanning priors
max_index <- 1
for ( h in 2:length(flist) ) {
if ( class(flist[[h]][[2]])=="call" ) {
if ( is.call(flist[[h]][[2]]) ) {
if ( as.character(flist[[h]][[2]][[2]])=="[" & as.character(flist[[h]][[2]][[3]])==the_par ) {
nval <- suppressWarnings( as.numeric(flist[[h]][[2]][[3]]) )
if ( !is.null(nval) ) {
Expand Down Expand Up @@ -463,7 +463,7 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA
suppressWarnings(optim( par=pars , fn=make_minuslogl , flist=flist2 , data=data , veclist=veclist , hessian=hessian , method=method , ... ))
, silent=TRUE
)
if ( class(fit)=="try-error" ) {
if ( inherits(fit, "try-error") ) {
# something went wrong...try to figure it out
msg <- attr(fit,"condition")$message

Expand Down Expand Up @@ -503,7 +503,7 @@ quap <- function( flist , data , start , method="BFGS" , hessian=TRUE , debug=FA

if ( hessian & dofit ) {
vcov <- try( solve(fit$hessian) )
if ( class(vcov)[1]=="try-error" ) {
if ( inherits(vcov, "try-error") ) {
warning( "Error when computing variance-covariance matrix (Hessian). Fit may not be reliable." )
vcov <- matrix( NA , nrow=length(pars) , ncol=length(pars) )
}
Expand Down