R/widget.R

In jbkunst/treeki: Widget For Tree Based Model Build

#' treeki the widget for tree predictive algorithms
#' treeki the widget for tree predictive algorithms
#' @param data The data to work with.
#' @param viewer Specify where the gadget should be displayed–viewer pane,
#'   dialog window, or external browse. For example use
#'   \code{viewer = shiny::browserViewer()}.
#' @param ... Additional parameters.
#' @examples
#'
#' \dontrun{
#'
#' # example 1
#' data <- subset(airquality, !is.na(Ozone) & complete.cases(airquality))
#' treeki(data)
#'
#' # example 2
#' data(BBBClub, package = "evtree")
#' require(shiny) # for browserViewer()
#' treeki(BBBClub, viewer = browserViewer())
#'
#' }
#'
#' @importFrom shiny fillPage
#' @importFrom shinythemes shinytheme
#' @importFrom graphics plot
#' @importFrom stats as.formula
#' @importFrom miniUI miniPage gadgetTitleBar
#' @importFrom shiny paneViewer stopApp selectInput sliderInput
#'   plotOutput observeEvent renderPlot runGadget shinyApp
#'   reactive dialogViewer tags column fluidRow icon
#' @importFrom partykit ctree ctree_control as.party
#' @importFrom rpart rpart rpart.control
#' @importFrom evtree evtree evtree.control
#' @export
treeki <- function(data, viewer = dialogViewer("treeki", 1200, 900), ...) {

  # library(shiny); library(shinythemes); library(miniUI); library(partykit); library(rpart); library(evtree)
  # viewer = dialogViewer("treeki", 1200, 900)
  # data <- subset(airquality, !is.na(Ozone) & complete.cases(airquality))
  # input <- list(package = "ctree", var = vars[1], vars = vars[-1], depth = 3, minbucket = 20,
  #               fontsize = 12, abbr = FALSE, showid = FALSE)

  vars <- names(data)

  mainpanel <- tabPanel(
    NULL,
    icon = icon("tachometer"),
    fluidRow(
      column(
        12,
        tags$form(
          class = "well",
          selectInput("package", "Algorithm (package)",
                      c("Conditional Inference Trees" = "ctree",
                        "Recursive Partitioning and Regression Trees" = "rpart",
                        "Evolutionary Learning of Globally Optimal Trees" = "evtree")
                      ),
          #----------------------------
          selectInput("var", "Variable to predict", vars, vars[1]),
          selectInput("vars", "Predictors", vars, vars, multiple = TRUE),
          #----------------------------
          sliderInput("depth", "Max Depth", min = 1, max = 10, value = 5),
          sliderInput("minbucket", "Min Bucket (% of rows)", min = 0, max = 30, post = " %", value = 10)
        )
      )
    )
  )

  optspanel <- tabPanel(
    NULL,
    icon = icon("eye"),
    fluidRow(
      column(
        12,
        tags$form(
          class = "well",
          sliderInput("fontsize", "Font size", 5, 20, 12),
          checkboxInput("abbr", "Abbreviate"),
          checkboxInput("showid", "Show node id")
          )
        )
      )
    )

  panel <- tabsetPanel(
    mainpanel,
    optspanel
    )

  ui <- miniPage(
    theme = shinytheme("paper"),
    gadgetTitleBar("Treeki"),
    fluidRow(
      column(3, panel),
      column(9, plotOutput("treeplot"))
    )
  )

  server <- function(input, output, session) {

    observeEvent(input$done, { stopApp(tree()) })

    tree <- reactive({

      package <- input$package

      modfun = switch(
        package,
        ctree = ctree,
        rpart = rpart,
        evtree = evtree
        )

      ctrfun <- switch(
        package,
        ctree = ctree_control,
        rpart = rpart.control,
        evtree = evtree.control
      )

      mb <- round(input$minbucket / 100 * nrow(data))
      ctr <- ctrfun(maxdepth = input$depth, minbucket = mb)

      f <- paste0(input$var, " ~ ", paste0(input$vars, collapse = " + "))

      tree <- suppressWarnings(
        modfun(as.formula(f), data = data, control = ctr)
      )

      tree

    })

    output$treeplot <- renderPlot({

      tree <- tree()
      package <- input$package

      plotfun <- switch(
        package,
        ctree = plot,
        rpart = function(x) plot(as.party(x)),
        evtree = plot
      )

      plotfun(
        tree,
        gp = gpar(fontsize = input$fontsize),
        inner_panel=node_inner,
        ip_args = list(
          abbreviate =  input$abbr,
          id = input$showid
          )
        )

    })


  }

  runGadget(shinyApp(ui, server), viewer = viewer)

}