R/plot.stlpp.R

In Moradii/stlnpp: Spatio-Temporal Analysis of Point Patterns on Linear Networks

#' @import graphics
#' @export
plot.stlpp=function(x, xlab=xlab, onlypoints=FALSE, onlytime=FALSE, ...){

  if (inherits(x, "stlpp") == FALSE) stop("x should be an object of stlpp")
  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar)) 
  
  if(onlypoints){
    plot(as.lpp.stlpp(x), main = "xy-locations on linear network",...)
  }else if(onlytime){
    xx = sort(as.data.frame(x$data[,3])[,1], index.return = TRUE)
    x1 = x$data[xx$ix, ]
    x1=as.data.frame(x1)
    if (missing(xlab)) xlab <- "time"
    plot(x1[, 3], cumsum(x1[, 3]), type = "l", xlab=xlab,
         ylab = "", main = "cumulative number", las = 1
         ,xlim=c(min(x1[,3]),max(x1[,3])),...)
  }else{
    par(mfrow = c(1, 2), pty = "s")
    plot(as.lpp.stlpp(x), main = "xy-locations on linear network",...)
    xx = sort(as.data.frame(x$data[,3])[,1], index.return = TRUE)
    x1 = x$data[xx$ix, ]
    x1=as.data.frame(x1)
    if (missing(xlab)) xlab <- "time"
    plot(x1[, 3], cumsum(x1[, 3]), type = "l", xlab=xlab,
         ylab = "", main = "cumulative number", las = 1
         ,xlim=c(min(x1[,3]),max(x1[,3])),...)
  }
}

#' @export
plot.tpp=function(x, onlypoints=FALSE, onlytime=FALSE, xlab=xlab,...){
  
  if (inherits(x, "tpp") == FALSE) stop("x should be an object of tpp")
  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar)) 
  
  t <- x$data$t
  
  if(onlypoints){
    y_values <- rep(0, npoints(x))
    plot(t, y_values, yaxt = "n", bty = "n", ...)
    
  }else if(onlytime){
    xx = sort(t, index.return = TRUE)
    t = t[xx$ix]
    plot(t, cumsum(t), type = "l", las = 1,
         xlim=c(min(t),max(t)), ...)
  }
  else{
    par(mfrow = c(1, 2), pty = "s")
    y_values <- rep(0, npoints(x))
    plot(t, y_values, yaxt = "n", bty = "n", ylab="", ...)
    
    xx = sort(t, index.return = TRUE)
    x1 = t[xx$ix]
    if (missing(xlab)) xlab <- "time"
    plot(x1, cumsum(x1), type = "l", xlab=xlab,
         ylab = "", main = "cumulative number", las = 1
         ,xlim=c(min(x1),max(x1)),...)
  }
}


#' @export
plot.stlppint <- function(x,style=style,xlab=xlab,xlim=xlim,ylim=ylim,bar=TRUE,...){
  
  if (inherits(x, "stlppint") == FALSE) stop(" x must be from class stlppint")
  
  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar))
  
  t <- attr(x,"time")
  par(mfrow=c(1,2))
  
  if(is.null(attr(x,"tempden")) & is.null(attr(x,"tint"))){
    onL <- as.linim.stlppint(x)
    onT <- as.tppint.stlppint(x)
    
    tgrid <- attr(onT,"tgrid")
    
    if (missing(xlim)) xlim <- range(tgrid)
    if (missing(xlab)) xlab <- "time"
    if (missing(ylim)) ylim = c(0,max(onT,table(round(t))))
      
    plot(tgrid,onT,ylab="",main="",
         type="l",ylim = ylim,
         xlab=xlab,xlim = xlim,...)
    if(bar) points(table(round(t))) 
    title(ylab=expression(hat(lambda)[time]), line=2,cex=3,...)
    
    if (missing(style)) {plot(onL,main="",...)}
    else {plot(onL,main="",style=style,...)}
  }
  else if(!is.null(attr(x,"tempden"))){
    d <- attr(x,"tempden")
    int <- length(t)*d$y
    
    if (missing(xlim)) xlim <- range(d$x)
    if (missing(ylim)) ylim = c(0,max(int,table(round(t))))
    OK <- d$x>=range(xlim)[1] & d$x<=range(xlim)[2]
    if (missing(xlab)) xlab <- "time"
    plot(d$x[OK],int[OK],
         ylab="",main="",type="l",ylim = ylim,xlab=xlab,xlim = xlim,...)
    if(bar) points(table(round(t)))
    title(ylab=expression(hat(lambda)[time]), line=2,cex=3,...)
    
    if (missing(style)) {plot(attr(x,"netint"),main="",...)}
    else {plot(attr(x,"netint"),main="",style=style,...)}
  }
  else{
    d <- attr(x,"tint")
    tgrid <- attr(x,"tgrid")
    
    if (missing(xlim)) xlim <- range(tgrid)
    if (missing(xlab)) xlab <- "time"
    if (missing(ylim)) ylim = c(0,max(d,table(round(t))))
    
    plot(tgrid,d,ylab="",main="",
         type="l",ylim = ylim,
         xlab=xlab,xlim = xlim,...)
    if(bar) points(table(round(t)))
    title(ylab=expression(hat(lambda)[time]), line=2,cex=3,...)
    
    if (missing(style)) {plot(attr(x,"lint"),main="",...)}
    else {plot(attr(x,"lint"),main="",style=style,...)}
  }
  
}

#' @export
plot.sumstlpp <- function(x,style=c("level","contour","perspective"),theta=35,phi=10,
                          facets=FALSE,ticktype= "detailed",resfac=5,
                          xlab="r = distance",ylab="t = time",
                          ...){

  if(missing(style)) style="level"
  if (!inherits(x, "sumstlpp")) stop("x is not an object of class sumstlpp")

  if (!requireNamespace("lattice", quietly = TRUE))
    stop("lattice required: install lattice and try again")
  
  if (!requireNamespace("graphics", quietly = TRUE))
    stop("graphics required: install graphics and try again")
  
  if (!requireNamespace("plot3D", quietly = TRUE))
    stop("plot3D required: install plot3D and try again")
  
  if(any(names(x)=="Kest")){

    if (style=="level"){
      plot(lattice::levelplot(x$Kest,row.values=x$r,column.values=x$t,xlab=xlab,ylab=ylab,...))
    }

    if (style=="contour"){
      graphics::contour(x$Kest,x=x$r,y=x$t,xlab=xlab,ylab=ylab,...)
    }

    if (style=="perspective"){
      plot3D::persp3D(x$r,x$t,x$Kest,
              xlab=xlab,ylab=ylab,zlab="",
              main=expression(italic({hat(K)[L]^{ST}}(r,t))),
              zlim= range(c(min(x$Kest,x$Ktheo),max(x$Kest,x$Ktheo))),
              theta=theta,phi=phi,
              facets=facets,ticktype= ticktype,resfac=resfac,
              ...)
    }

  }

  else if (any(names(x)=="gest")){

    if (style=="level"){
      plot(lattice::levelplot(x$gest,row.values=x$r,column.values=x$t,
                              xlab=xlab,ylab=ylab,...))
    }

    if (style=="contour"){
      graphics::contour(x$gest,x=x$r,y=x$t,xlab=xlab,ylab=ylab,...)
    }

    if (style=="perspective"){
      plot3D::persp3D(x$r,x$t,x$gest,
            xlab=xlab,ylab=ylab,zlab="",
            main=expression(italic({hat(g)[L]^{ST}}(r,t))),
            zlim= range(c(min(x$gest,x$gtheo),max(x$gest,x$gtheo))),
            theta=theta,phi=phi,
            facets=facets,ticktype= ticktype,resfac=resfac,
            ...)
   }
    }

  else if (any(names(x)=="Kinhom")){

    if (style=="level"){
      plot(lattice::levelplot(x$Kinhom,row.values=x$r,column.values=x$t,
                              xlab=xlab,ylab=ylab,...))
    }

    if (style=="contour"){
      graphics::contour(x$Kinhom,x=x$r,y=x$t,xlab=xlab,ylab=ylab,...)
    }



    if (style=="perspective"){
      plot3D::persp3D(x$r,x$t,x$Kinhom,
            xlab=xlab,ylab=ylab,zlab="",
            main=expression(italic({hat(K)[LI]^{ST}}(r,t))),
            zlim= range(c(min(x$Kinhom,x$Ktheo),max(x$Kinhom,x$Ktheo))),
            theta=theta,phi=phi,
            facets=facets,ticktype= ticktype,resfac=resfac,
            ...)

    }
    }

  else if (any(names(x)=="ginhom")){

    if (style=="level"){
      plot(lattice::levelplot(x$ginhom,row.values=x$r,column.values=x$t
                              ,xlab=xlab,ylab=ylab,...))
    }

    if (style=="contour"){
      graphics::contour(x$ginhom,x=x$r,y=x$t,xlab=xlab,ylab=ylab,...)
    }

    if (style=="perspective"){
      plot3D::persp3D(x$r,x$t,x$ginhom,
            xlab=xlab,ylab=ylab,zlab="",
            main=expression(italic({hat(g)[LI]^{ST}}(r,t))),
            zlim= range(c(min(x$ginhom,x$gtheo),max(x$ginhom,x$gtheo))),
            theta=theta,phi=phi,
            facets=facets,ticktype= ticktype,resfac=resfac,
            ...)

    }
    }

}