R/generics.R

In BLPestimatoR: Performs a BLP Demand Estimation

#' @importFrom stats dnorm
#' @importFrom stats pnorm
#' @importFrom stats qnorm
#' @importFrom stats rnorm
#' @importFrom stats runif
#' @importFrom stats pchisq
#' @importFrom stats na.omit
#' @importFrom methods is
#'
#' @export
summary.blp_est <- function( object , ... ){

  if( !is(object,"blp_est"))
    stop("Argument is not of class blp.")

  ans <- object

  est.linear <- ans$theta_lin
  se.linear <- ans$se_linear
  tval.linear <- est.linear/se.linear

  est.rc <- ans$theta_rc
  se.rc <- ans$se_rc
  tval.rc <- est.rc/se.rc


  ans$LinCoefficients <- as.data.frame( cbind( est.linear ,
                                               se.linear ,
                                               tval.linear ,
                                               2 * pnorm(abs(tval.linear ),
                                                          lower.tail = FALSE)) )
  ans$AmountLinCoef <- length(est.linear)

  ans$RcCoefficients <- as.data.frame( cbind(est.rc,
                                             se.rc,
                                             tval.rc,
                                             2 * pnorm(abs(tval.rc),
                                                       lower.tail = FALSE)) )
  ans$amount_par <- length(est.rc)

  # Rownames mit Demographic / RC angabe

  names_par <- kronecker( ans$rand_coef_colnames ,
                          ans$rand_coef_rownames, paste, sep="*")
  relevantRcDem_index <- ans$indices[,"row"] +
    max( ans$indices[,"row"] ) * ( ans$indices[,"col"] - 1 )

  names( ans$LinCoefficients ) <- c("Estimate", "Std. Error", "t value", "Pr(>|t|)")
  names( ans$RcCoefficients ) <- c("Estimate", "Std. Error", "t value", "Pr(>|t|)")
  rownames( ans$RcCoefficients ) <- names_par[ relevantRcDem_index ]

  # Waldstat
  ans$wald_pvalue <- pchisq( ans$WaldStatistic ,
                             df = ans$amount_par,
                             lower.tail = FALSE )


  class(ans) <- "blpSummary"
  return(ans) # printing ans
}




#' @export
print.blpSummary <- function( x, ... ){

  if( !is(x,"blpSummary"))
    stop("Argument is not of class *blpSummary* .")

  ##
  x$call_arguments
  ##
  cat("\nData information:\n")
    cat( "\n\t", paste0( x[['#nmkt']] , " market(s) with " , x[['#nobs']] , " products") , "\n" )
    cat( "\t", paste0( x[['AmountLinCoef']] , " linear coefficient(s) (" , x[['#exoCoef']] , " exogenous coefficients)") , "\n" )
    cat( "\t", paste0( x[['amount_par']] , " non-linear parameters related to random coefficients" ) , "\n" )
    cat( "\t", paste0( x[['#demogrCoef']] , " demographic variable(s)" ) , "\n" )

  ##
  cat("\nEstimation results:\n")

  cat("\n Linear Coefficients\n")
      if( x$AmountLinCoef <= 20){
        print( x$LinCoefficients )
      } else {
        print( x$LinCoefficients[1:20, ] )
        cat( "\n...\n" )
        cat( paste("\n", x$AmountLinCoef - 20,
                   "estimates are omitted. They are available in the LinCoefficients generated by summary.\n" ) )
      }


  cat("\n Random Coefficients\n")
      if( x$amount_par <= 20){
        print( x$RcCoefficients )
      } else {
        print( x$RcCoefficients[1:20, ] )
        cat( "\n...\n" )
        cat( paste("\n", x$amount_par - 20,
                   "estimates are omitted. They are available in the x generated by summary.\n" ) )
      }


  cat("\n Wald Test\n")
  cat( paste( round( x$WaldStatistic , 4 ), "on ",
                x$amount_par , "DF, p-value:" ,
                x$wald_pvalue, "\n"  ))


  ##
  cat("\nComputational Details: \n")
    cat( "\t", paste0("Solver converged with ", x$outer_it," iterations to a minimum at ",
                      round( x$local_min, 4 )) ,".\n" )
    cat( "\t", paste0("Local minima check: ", x$IslocalMin , "\n" ))
    cat( "\t", paste0("stopping criterion outer loop: " , x$outerCrit, "\n" ))
    cat( "\t", paste0("stopping criterion inner loop: " , x$innerCrit , "\n" ))
    cat( "\t", paste0("Market shares are integrated with " , x$intMethod , " and ", x$intdraws ," draws. \n" ))
    cat( "\t", paste0("Method for standard errors: " , x$standardErrorMethod , "\n" ))

}