R/summary.bestfit.R

In lfpdroubi/appraiseR: R Package For Real Estate Appraisals

#' Summary method for class bestfit
#'
#' \code{summary} method for class \code{\link{bestfit}} produce result summary
#' containing the formula for the best (chosen) fit and the \code{summary.lm}
#' for that fit.
#'
#' @param object an object of class \code{\link{bestfit}}.
#' @param fit the number of the chosen fit from the combination matrix (defaults
#'   for the best fit found with \code{\link{bestfit}}).
#' @param subset a specification of the rows to be used: defaults to all rows.
#'   This can be any valid indexing vector (see \link{[.data.frame}) for the
#'   rows of data or if that is not supplied, a data frame made up of the
#'   variables used in \code{formula}.
#' @param \dots not used.
#' @return Returns the call for the \code{\link{bestfit}} function, the best
#'   (chosen) fit number, the \code{lm }formula and the \code{lm} fit summary
#'   for the best (chosen) fit transformations found by \code{\link{bestfit}}.
#'
#' @export
#' @examples
#' library(sf)
#' centro_2015 <- st_drop_geometry(centro_2015)
#' centro_2015 <- within(centro_2015, PU <- valor/area_total)
#' best_fit <- bestfit(PU ~ area_total + quartos + suites + garagens +
#'                     dist_b_mar + padrao,
#'                     data = centro_2015,
#'                     transf = c("rec", "rsqrt", "log", "sqrt"))
#' summary(best_fit)
#' summary(best_fit, fit = 514)
summary.bestfit <- function(object, fit = bestfits(object)$df$id[1],
                            subset, ...){
  id <- NULL #just for R CMD check

  #z <- object
  tabela <- object$tab
  preds <- object$predictors

  LHS <- paste0(base::subset(tabela, id == fit,
                                   select = object$response, drop = TRUE),
                      "(", object$response, ")")
  if (length(preds)>0) {
    terms_x <- sapply(preds, function (x) paste0(base::subset(tabela,
                                                              id == fit,
                                                              select = x,
                                                              drop = TRUE),
                                                 "(", x, ")"))
    RHS <- paste0(terms_x, collapse = " + ")
  } else {
    RHS <- " 1"
  }

  f <- as.formula(paste0(LHS, " ~ ", RHS))

  if(!is.null(object$call$extras)) {
    extras <- eval(object$call$extras, environment(formula(object)))
    ff <- foo ~ bar + baz
    if (is.call(extras))
      gg <- extras
    else
      gg <- parse(text=paste("~", paste(extras, collapse="+")))[[1L]]
    ff[[2L]] <- f[[2L]]
    ff[[3L]][[2L]] <- f[[3L]]
    ff[[3L]][[3L]] <- gg[[2L]]
  } else {
    ff <- f
  }

  args <- list(ff, data = eval(stats::getCall(object)$data,
                               environment(formula(object))))

  if (!missing(subset)) {
    args$subset <- subset
  } else {
    args$subset <- object$subset
  }

  model <- do.call("lm", args)
  #g <- call("lm", formula = ff, data = eval(stats::getCall(object)$data,
  #                                          environment(formula(object))))
  #model <- eval(g)

  g <- grau(model)

  bfits <- bestfits(object)

  est <- list(call = object$call,
              bestfit = bfits,
              formula = ff,
              fit = model,
              table = tabela,
              nmin = g$nmin,
              tmax = g$tmax,
              fstat = g$fstat)
  class(est) <- "summary.bestfit"
  est
}

#' @export
#'
mystarformat <- function(x) symnum(x, corr = FALSE, na = FALSE,
                                   cutpoints = c(0, 0.10, 0.20, 0.30, 1),
                                   symbols = c("***", "**", "*", " "))

#' @export
#'
show_coef <- function(fit) {
  mycoef<-data.frame(coef(summary(fit)), check.names=F)
  mycoef$signif = mystarformat(mycoef$`Pr(>|t|)`)
  mycoef$`Pr(>|t|)` = format.pval(mycoef$`Pr(>|t|)`)
  mycoef
}

#' @export

print.summary.bestfit <- function(x, ...){
  cat("Call:\n")
  print(x$call)
  cat("\nBest (Chosen) Transformations:\n")
  print(x$bestfit)
  cat("\nBest (Chosen) fit LM summary:\n")
  print(show_coef(x$fit))
  cat("---\n Signif. codes:  0 ‘***’ 0.10 ‘**’ 0.20 ‘*’ 0.30 ‘ ’ 1\n")
  cat("NBR-14.653-2 check:\n")
  cat("Number of market data used:\n")
  print(x$nmin)
  cat("Max significance level allowed for each predictor:\n")
  print(x$tmax)
  cat("Max significance level allowed for F-test:\n")
  print(x$fstat)
}