R/bestfits.R

In lfpdroubi/appraiseR: R Package For Real Estate Appraisals

#' Comparison table for best models with different transformations
#'
#' \code{bestfits} creates a table with AIC, Adjusted R2 and other statistics
#' for model comparisons. In order to make possible far comparisons, an adjusted
#' version of AIC for transformations is used.
#' @param obj object of class bestfit
#'
#' @examples
#' library(appraiseR)
#' library(sf)
#' data(centro_2015)
#' 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", "log", "sqrt"))
#' (b <- bestfits(best_fit))
#'
#' library(sjPlot)
#' tab_model(b$models, show.aic = T)
#'
#' @export
bestfits <- function(obj, ...){

  tabela <- obj$tab
  preds <- obj$predictors

  DepVarTransfs <- unique(tabela[, obj$response])

  DF <- list()

  for (i in DepVarTransfs){
    tab <- tabela[which(tabela[, obj$response] == i), ]
    DF[[i]] <- tab[which.min(tab$AIC), ]
  }

  DF <- as.data.frame(t(sapply(DF, FUN = rbind, simplify = T)))
  models <- list()

  for (i in seq_len(nrow(DF))) {
    LHS <- paste0(base::subset(tabela, id == DF$id[i],
                                       select = obj$response, drop = TRUE),
                          "(", obj$response, ")")
    if (length(preds)>0) {
      terms_x <- sapply(preds, function (x) paste0(base::subset(tabela,
                                                                id == DF$id[i],
                                                                select = x,
                                                                drop = TRUE),
                                                   "(", x, ")"))
      RHS <- paste0(terms_x, collapse = " + ")
    } else {
      RHS <- " 1"
    }
    f <- as.formula(paste0(LHS, " ~ ", RHS))

    if(!is.null(obj$call$extras)) {
      extras <- eval(obj$call$extras, environment(formula(obj)))
      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(obj)$data,
                                 environment(formula(obj))))

    args$subset <- obj$subset

    models[[i]] <- do.call("lm", args)

    # g <- call("lm", ff, eval(stats::getCall(obj)$data,
    #                               environment(formula(obj))))
    # models[[i]] <- eval(g)

    DF$adj_AIC[i] <- round(aic(models[[i]]), 2)
    DF$adj_AICc[i] <- round(aicc(models[[i]]), 2)
  }

  DF <- DF[order(DF$adj_AIC), ]

  z <- list()

  z$df <- DF
  z$models <- models

  class(z) <- "bestfits"

  return(z)
}

#' @export

print.bestfits <- function(x, ...){
  cat("Bestfits:\n")
  print(x$df[, setdiff(colnames(x$df), "BIC")])
}