Skip to content

Commit

Permalink
add return argument
Browse files Browse the repository at this point in the history
  • Loading branch information
@bmcclintock
bmcclintock committed Dec 19, 2023
1 parent 33b976e commit a7cdc56
Show file tree
Hide file tree
Showing 7 changed files with 59 additions and 17 deletions.
19 changes: 10 additions & 9 deletions R/plotStationary.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -274,34 +274,35 @@ statPlot<-function(model,Sigma,nbStates,formula,covs,tempCovs,tmpcovs,cov,hierRe

if(isTRUE(model$conditions$CT)) tempCovs$dt <- covs$dt
out <- vector('list',mixtures)
names(out) <- paste0("mix",1:mixtures)

for(mix in 1:mixtures){
if(!inherits(model,"hierarchical")){
out[[mix]] <- plotCall(cov,tempCovs,probs[[mix]],model,nbStates,covnames,lwd,arg,col,legend.pos,cex.legend,plotCI,gridLength,hierRecharge,desMat,mix,Sigma,gamInd,alpha,1:nbStates,model$stateNames,formula)
out[[paste0("mix",mix)]] <- plotCall(cov,tempCovs,probs[[mix]],model,nbStates,covnames,lwd,arg,col,legend.pos,cex.legend,plotCI,gridLength,hierRecharge,desMat,mix,Sigma,gamInd,alpha,1:nbStates,model$stateNames,formula)
if(length(covnames)>1) do.call(mtext,c(list(paste0(ifelse(mixtures>1,paste0("Mixture ",mix," s"),"S"),"tationary state probabilities: ",paste(covnames[-cov]," = ",tmpcovs[-cov],collapse=", ")),side=3,outer=TRUE,padj=2,cex=cex.main),marg))
else do.call(mtext,c(list(paste0(ifelse(mixtures>1,paste0("Mixture ",mix," s"),"S"),"tationary state probabilities"),side=3,outer=TRUE,padj=2,cex=cex.main),marg))
} else {
out[[mix]] <- vector('list',model$conditions$hierStates$height-1)
names(out[[mix]]) <- paste0("level",1:(model$conditions$hierStates$height-1))
out[[paste0("mix",mix)]] <- vector('list',model$conditions$hierStates$height-1)
names(out[[paste0("mix",mix)]]) <- paste0("level",1:(model$conditions$hierStates$height-1))
for(j in 1:(model$conditions$hierStates$height-1)){
if(j==1) {
# only plot if there is variation in stationary state proabilities
if(!all(apply(probs[[mix]][["level1"]],2,function(x) all( abs(x - mean(x)) < 1.e-6 )))){
ref <- model$conditions$hierStates$Get(function(x) data.tree::Aggregate(x,"state",min),filterFun=function(x) x$level==j+1)
out[[mix]][[paste0("level",j)]] <- plotCall(cov,tempCovs[which(tempCovs$level==j),],probs[[mix]][["level1"]],model,nbStates,covnames,lwd,arg,col,legend.pos,cex.legend,plotCI,gridLength,hierRecharge,desMat[which(tempCovs$level==j),],mix,Sigma,gamInd,alpha,ref,names(ref),formula)
out[[paste0("mix",mix)]][[paste0("level",j)]] <- plotCall(cov,tempCovs[which(tempCovs$level==j),],probs[[mix]][["level1"]],model,nbStates,covnames,lwd,arg,col,legend.pos,cex.legend,plotCI,gridLength,hierRecharge,desMat[which(tempCovs$level==j),],mix,Sigma,gamInd,alpha,ref,names(ref),formula)
if(length(covnames[-cov][which(covnames[-cov]!="level" & !grepl("recharge",covnames[-cov]))])) do.call(mtext,c(list(paste0(ifelse(mixtures>1,paste0("Mixture ",mix," s"),"S"),"tationary state probabilities for level",j,": ",paste(covnames[-cov][which(covnames[-cov]!="level" & !grepl("recharge",covnames[-cov]))]," = ",tmpcovs[which(tmpcovs$level==j),-cov][which(covnames[-cov]!="level" & !grepl("recharge",covnames[-cov]))],collapse=", ")),side=3,outer=TRUE,padj=2,cex=cex.main),marg))
else do.call(mtext,c(list(paste0(ifelse(mixtures>1,paste0("Mixture ",mix," s"),"S"),"tationary state probabilities for level",j),side=3,outer=TRUE,padj=2,cex=cex.main),marg))
}
} else {
t <- data.tree::Traverse(model$conditions$hierStates,filterFun=function(x) x$level==j)
names(t) <- model$conditions$hierStates$Get("name",filterFun=function(x) x$level==j)
out[[mix]][[paste0("level",j)]] <- vector('list',length(names(t)))
names(out[[mix]][[paste0("level",j)]]) <- names(t)
out[[paste0("mix",mix)]][[paste0("level",j)]] <- vector('list',length(names(t)))
names(out[[paste0("mix",mix)]][[paste0("level",j)]]) <- names(t)
for(k in names(t)){
ref <- t[[k]]$Get(function(x) data.tree::Aggregate(x,"state",min),filterFun=function(x) x$level==j+1)#t[[k]]$Get("state",filterFun = data.tree::isLeaf)
# only plot if jth node has children and there is variation in stationary state proabilities
if(!is.null(ref) && !all(apply(probs[[mix]][[paste0("level",j)]][[k]],2,function(x) all( abs(x - mean(x)) < 1.e-6 )))){
out[[mix]][[paste0("level",j)]][[k]] <- plotCall(cov,tempCovs[which(tempCovs$level==j),],probs[[mix]][[paste0("level",j)]][[k]],model,nbStates,covnames,lwd,arg,col,legend.pos,cex.legend,plotCI,gridLength,hierRecharge,desMat[which(tempCovs$level==j),],mix,Sigma,gamInd,alpha,ref,names(ref),formula)
out[[paste0("mix",mix)]][[paste0("level",j)]][[k]] <- plotCall(cov,tempCovs[which(tempCovs$level==j),],probs[[mix]][[paste0("level",j)]][[k]],model,nbStates,covnames,lwd,arg,col,legend.pos,cex.legend,plotCI,gridLength,hierRecharge,desMat[which(tempCovs$level==j),],mix,Sigma,gamInd,alpha,ref,names(ref),formula)
if(length(covnames[-cov][which(covnames[-cov]!="level" & !grepl("recharge",covnames[-cov]))])) do.call(mtext,c(list(paste0(ifelse(mixtures>1,paste0("Mixture ",mix," s"),"S"),"tationary state probabilities for level",j," ",k,": ",paste(covnames[-cov][which(covnames[-cov]!="level" & !grepl("recharge",covnames[-cov]))]," = ",tmpcovs[which(tmpcovs$level==j),-cov][which(covnames[-cov]!="level" & !grepl("recharge",covnames[-cov]))],collapse=", ")),side=3,outer=TRUE,padj=2,cex=cex.main),marg))
else do.call(mtext,c(list(paste0(ifelse(mixtures>1,paste0("Mixture ",mix," s"),"S"),"tationary state probabilities for level",j," ",k),side=3,outer=TRUE,padj=2,cex=cex.main),marg))
}
Expand All @@ -310,7 +311,7 @@ statPlot<-function(model,Sigma,nbStates,formula,covs,tempCovs,tmpcovs,cov,hierRe
}
}
}
if(plotCI && mixtures==1) out <- out[[1]]
if(plotCI && mixtures==1) out <- out[[paste0("mix",mix)]]
return(out)
}

Expand Down Expand Up @@ -377,7 +378,7 @@ plotCall <- function(cov,tempCovs,pr,model,nbStates,covnames,lwd,arg,col,legend.
uci[ciInd,state], length=0.025, angle=90, code=3, col=col[ref[state]], lwd=lwd),arg)),warning=muffWarn)

out[[stateNames[state]]] <- data.frame(est=pr[,state],se=c(se),lci=lci[,state],uci=uci[,state])
out[[stateNames[state]]]$cov <- tempCovs[,cov]
out[[stateNames[state]]][[names(tempCovs[,cov,drop=FALSE])]] <- tempCovs[,cov]

}
return(out)
Expand Down
5 changes: 3 additions & 2 deletions R/plot_miHMM.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@
#' @param alpha Significance level of the confidence intervals (if \code{plotCI=TRUE}). Default: 0.95 (i.e. 95\% CIs).
#' @param plotStationary Logical indicating whether to plot the stationary state probabilities as a function of any covariates (default: FALSE)
#' @param plotEllipse Logical indicating whether to plot error ellipses around imputed location means. Default: TRUE.
#' @param return Logical indicating whether to return a list containing estimates, SEs, CIs, and covariate values used to create the plots for each mixture and state. Ignored if \code{plotCI=FALSE}. Default: \code{FALSE}.
#' @param ... Additional arguments passed to \code{graphics::plot} and \code{graphics::hist} functions. These can currently include \code{asp}, \code{cex}, \code{cex.axis}, \code{cex.lab}, \code{cex.legend}, \code{cex.main}, \code{legend.pos}, and \code{lwd}. See \code{\link[graphics]{par}}. \code{legend.pos} can be a single keyword from the list ``bottomright'', ``bottom'', ``bottomleft'', ``left'', ``topleft'', ``top'', ``topright'', ``right'', and ``center''. Note that \code{asp} and \code{cex} only apply to plots of animal tracks.
#'
#' @details The state-dependent densities are weighted by the frequency of each state in the most
Expand Down Expand Up @@ -63,9 +64,9 @@
#' @export

plot.miHMM <- function(x,animals=NULL,covs=NULL,ask=TRUE,breaks="Sturges",hist.ylim=NULL,sepAnimals=FALSE,
sepStates=FALSE,col=NULL,cumul=TRUE,plotTracks=TRUE,plotCI=FALSE,alpha=0.95,plotStationary=FALSE,plotEllipse=TRUE,...)
sepStates=FALSE,col=NULL,cumul=TRUE,plotTracks=TRUE,plotCI=FALSE,alpha=0.95,plotStationary=FALSE,plotEllipse=TRUE,return=FALSE,...)
{
m <- x$miSum # the name "x" is for compatibility with the generic method
plot(m,animals,covs,ask,breaks,hist.ylim,sepAnimals,
sepStates,col,cumul,plotTracks,plotCI,alpha,plotStationary,plotEllipse,...)
sepStates,col,cumul,plotTracks,plotCI,alpha,plotStationary,plotEllipse,return,...)
}
5 changes: 3 additions & 2 deletions R/plot_miSum.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@
#' @param alpha Significance level of the confidence intervals (if \code{plotCI=TRUE}). Default: 0.95 (i.e. 95\% CIs).
#' @param plotStationary Logical indicating whether to plot the stationary state probabilities as a function of any covariates (default: FALSE)
#' @param plotEllipse Logical indicating whether to plot error ellipses around imputed location means. Default: TRUE.
#' @param return Logical indicating whether to return a list containing estimates, SEs, CIs, and covariate values used to create the plots for each mixture and state. Ignored if \code{plotCI=FALSE}. Default: \code{FALSE}.
#' @param ... Additional arguments passed to \code{graphics::plot} and \code{graphics::hist} functions. These can currently include \code{asp}, \code{cex}, \code{cex.axis}, \code{cex.lab}, \code{cex.legend}, \code{cex.main}, \code{legend.pos}, and \code{lwd}. See \code{\link[graphics]{par}}. \code{legend.pos} can be a single keyword from the list ``bottomright'', ``bottom'', ``bottomleft'', ``left'', ``topleft'', ``top'', ``topright'', ``right'', and ``center''. Note that \code{asp} and \code{cex} only apply to plots of animal tracks.
#'
#' @details The state-dependent densities are weighted by the frequency of each state in the most
Expand Down Expand Up @@ -64,7 +65,7 @@
#' @export

plot.miSum <- function(x,animals=NULL,covs=NULL,ask=TRUE,breaks="Sturges",hist.ylim=NULL,sepAnimals=FALSE,
sepStates=FALSE,col=NULL,cumul=TRUE,plotTracks=TRUE,plotCI=FALSE,alpha=0.95,plotStationary=FALSE,plotEllipse=TRUE,...)
sepStates=FALSE,col=NULL,cumul=TRUE,plotTracks=TRUE,plotCI=FALSE,alpha=0.95,plotStationary=FALSE,plotEllipse=TRUE,return=FALSE,...)
{
m <- x # the name "x" is for compatibility with the generic method
m <- delta_bc(m)
Expand All @@ -82,5 +83,5 @@ plot.miSum <- function(x,animals=NULL,covs=NULL,ask=TRUE,breaks="Sturges",hist.y
m <- momentuHMM(m)

plot.momentuHMM(m,animals,covs,ask,breaks,hist.ylim,sepAnimals,
sepStates,col,cumul,plotTracks,plotCI,alpha,plotStationary,...)
sepStates,col,cumul,plotTracks,plotCI,alpha,plotStationary,return,...)
}
Loading

0 comments on commit a7cdc56

Please sign in to comment.