path: root/R/idframe.R

#' S3 class for storing input-output data. 
#'
#' \code{idframe} is an S3 class for storing and manipulating input-ouput data. It supports discrete time and frequency domain data.
#'
#' @param output dataframe/matrix/vector containing the outputs
#' @param input dataframe/matrix/vector containing the inputs
#' @param type indicates the domain of the data (Default:"time")
#' @param Ts sampling interval (Default: 1)
#' @param t.start Starting time (Valid only if type="time")
#' @param t.end End time. Optional Argument (Valid only if type="time")
#' @param tUnit Time Unit (Default: "seconds")
#' @param frequencies Vector containing the list of frequencies at which the data was 
#' recorded (Valid only if type="frequency")
#' @param fUnit Frequency Unit (Valid only if type="frequency")
#' @return an idframe object
#' 
#' @seealso  \code{\link{plot.idframe}}, the plot method for idframe objects, 
#' \code{\link{summary.idframe}}, the summary method for idrame objects
#' 
#' @examples
#' 
#' dataMatrix <- matrix(rnorm(1000),ncol=5) 
#' data <- idframe(output=dataMatrix[,3:5],input=dataMatrix[,1:2],Ts=1)
#' 
#' @export
idframe <- function(output=NULL,input=NULL,
                     type=c("time","freq")[1],Ts = 1,
                     t.start=0,t.end=NULL, tUnit = "seconds", 
                     frequencies = NULL, fUnit= "Hz"){
  
  ## Input Validation
  if(!(type %in% c("time","freq"))) # type validation
    stop("Unknown domain type")
  
  #if(length(output)!=0 && length(input)!=0){
  #   if(dim(output)[1]!=dim(input)[1]) # observation validation
  #   stop("Dimensions don't match")
  #}
  
  # Object Constructor
  dat <- list(output=data.frame(output),input=data.frame(input),type=type,Ts=Ts)
  n <- dim(output)[1]
  p <- dim(output)[2];m <- dim(input)[2]
  
  if(type=="freq"){

    if(is.null(frequencies)){
      frequncies <- seq(0,2*pi,length=n)
    }
    
    dat$frequencies <- frequencies
    dat$fUnit <- fUnit
    
  } else {
    
    if(is.null(t.end)) {
      t.end <- t.start + Ts*(n-1)
    } else {
      dat$Ts <- (t.end-t.start)/(n-1)
    }
    
    dat$t.start <- t.start; dat$t.end <- t.end
    dat$tUnit <- tUnit
  }
      
  class(dat) <- "idframe"
  return(dat)
}

#' Plotting idframe objects
#' 
#' Plotting method for objects inherting from class \code{idframe}
#' 
#' @param object an object of class \code{idframe}
#' @param par a list of arguments passed to par() before plotting.
#' @param col line color, to be passed to plot.(Default=\code{"steelblue"})
#' @param ... additional arguments to be passed to the \code{tfplot} function
#' 
#' @seealso \code{\link[tfplot]{tfplot}}
#' @examples
#' data(cstr)
#' plot(cstr,col="blue")
#' 
#' @export
plot.idframe <- function(object,par=list(mar=c(3,4,2,2)),
                         col="steelblue",...){
  if(object$type=="frequency"){
    p <- dim(object$output)[2];m <- dim(object$input)[2]
    
    if(p!=1 || m!=1){
      oask <- devAskNewPage(TRUE)
      on.exit(devAskNewPage(oask))
      
      for(i in seq(m)){
        for(j in seq(p)){
          par(mfrow=c(2,1),mar=c(3,4,2,2))
          plot(object$frequencies,object$output[,j],xlab=object$type,
               ylab=colnames(object$output)[j],type="l",...)
          plot(object$frequencies,object$input[,i],xlab=object$type,
               ylab=colnames(object$input)[i],type="l",...)
        }
      }
    } else {
      par(mfrow=c(2,1),mar=c(3,4,2,2))
      plot(object$frequencies,object$output[,1],xlab=object$type,
           ylab=colnames(object$output),type="l",...)
      plot(object$frequencies,object$input[,1],xlab=object$type,
           ylab=colnames(object$input),type="l",...)
    }  
  } else{
    require(tfplot)
    if(is.null(object$output)){
      data <- object$input
    } else if(is.null(object$input)){
      data <- object$output
    } else{
      data <- cbind(object$output,object$input)
    }
    datats <- ts(data,start=object$t.start,end=object$t.end,
                 frequency=floor(1/object$Ts))
    tfplot(datats,Xaxis=NULL,par=par,col=col,...)
  }
}

#' @export
summary.idframe <- function(object){
  out_sum <- summary(object$output)
  in_sum <- summary(object$input)
  
  out <- list(outputs=out_sum,inputs=in_sum,Ts=object$Ts,type=object$type,
              tUnit=object$tUnit,no_of_samples = dim(object$output)[1])
  if(object$type=="time"){
    out$t.start <- object$t.start;out$t.end <- object$t.end
  } else{
    out$frequencies <- summary(object$frequencies);out$fUnit <- object$fUnit
  }
  
  class(out) <- "summary.idframe"
  return(out)
}

#' @export
print.summary.idframe <- function(object,...){
  cat("Domain: ");cat(object$type)
  cat("\t\t Number of samples:");cat(object$no_of_samples)
  cat("\nSampling time: ")
  cat(object$Ts);cat(" ");cat(object$tUnit)
  
  if(object$type=="frequency"){
    cat("\t Frequency Unit: ");print(object$fUnit)
    cat("\n\n Frequeny Summary:")
    print(object$frequencies)
  }
  
  cat("\n\n")
  cat("Outputs \n")
  print(object$outputs)
  cat("\n")
  
  cat("Inputs \n")
  print(object$inputs)
}

#' S3 class for storing frequency response data
#' 
#' @param response complex vector/matrix containing the response
#' @param freq the frequencies at which the response is observed/estimated
#' @param Ts sampling time of data
#' 
#' @return an idfrd object
#' 
#' @note
#' The class can currently store only SISO Responses. Future versions will 
#' have support for multivariate data
#' 
#' @seealso
#' \code{\link{plot.idfrd}} for generating bode plots; \code{\link{spa}} and
#' \code{\link{etfe}} for estimating the frequency response given input/output data
#' 
#' @export
idfrd <- function(response,freq,Ts){
  out <- list(response=response,freq=freq,Ts=Ts)
  class(out) <- "idfrd"
  return(out)
}

#' Plotting idfrd objects
#' 
#' Generates the bode plot of the given frequency response data. It uses the
#' ggplot2 plotting engine
#' 
#' @param object An object of class \code{idframe}
#' 
#' @seealso \code{\link[ggplot2]{ggplot}}
#' 
#' @examples
#' data(frf)
#' frf <- spa(data) # Estimates the frequency response from data
#' plot(frf)
#' 
#' @export
plot.idfrd <- function(object){
  require(ggplot2);require(reshape2);require(signal)

  mag <- 20*log10(Mod(object$resp))
  phase <- -360/2/pi*unwrap(Arg(object$resp))
  sys_df <- data.frame(Frequency = object$freq,Gain = mag,Phase = phase)
  melted_sys_df <- melt(sys_df, id.var = c("Frequency"))
  
  bode <-  ggplot(sys_df, aes(x = Frequency)) + 
    geom_line(colour="steelblue") + scale_x_log10() + theme_bw() + 
    geom_vline(xintercept=max(object$freq),size=1.2)
  bode_gain <- bode + aes(y = Gain)
  bode_phase <- bode + aes(y = Phase)
  
  multiplot(bode_gain,bode_phase)
}

# Multiple plot function
#
# ggplot objects can be passed in ..., or to plotlist (as a list of ggplot objects)
# - cols:   Number of columns in layout
# - layout: A matrix specifying the layout. If present, 'cols' is ignored.
#
# If the layout is something like matrix(c(1,2,3,3), nrow=2, byrow=TRUE),
# then plot 1 will go in the upper left, 2 will go in the upper right, and
# 3 will go all the way across the bottom.
#
multiplot <- function(..., plotlist=NULL, file, cols=1, layout=NULL) {
  library(grid)
  
  # Make a list from the ... arguments and plotlist
  plots <- c(list(...), plotlist)
  
  numPlots = length(plots)
  
  # If layout is NULL, then use 'cols' to determine layout
  if (is.null(layout)) {
    # Make the panel
    # ncol: Number of columns of plots
    # nrow: Number of rows needed, calculated from # of cols
    layout <- matrix(seq(1, cols * ceiling(numPlots/cols)),
                     ncol = cols, nrow = ceiling(numPlots/cols))
  }
  
  if (numPlots==1) {
    print(plots[[1]])
    
  } else {
    # Set up the page
    grid.newpage()
    pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout))))
    
    # Make each plot, in the correct location
    for (i in 1:numPlots) {
      # Get the i,j matrix positions of the regions that contain this subplot
      matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE))
      
      print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row,
                                      layout.pos.col = matchidx$col))
    }
  }
}