R/plot_shiny.fosr.R

Defines functions plot_shiny.fosr

Documented in plot_shiny.fosr

#' Interactive Plotting for Functional-on-Scalar Regressions
#'
#' Produces an interactive plot illustrating a function-on-scalar
#' regression analysis.
#'
#' @param obj fosr object to be plotted.
#' @param xlab x axis label
#' @param ylab y axis label
#' @param title plot title
#' @param ... additional arguments passed to plotting functions
#'
#' @author Jeff Goldsmith \email{jeff.goldsmith@@columbia.edu},
#' Julia Wrobel \email{julia.wrobel@@cuanschutz.edu}
#'
#' @seealso \code{\link{plot_shiny}}
#' @import shiny
#' @import ggplot2
#' @importFrom reshape2 melt
#' @importFrom stats model.matrix terms
#'
#' @export
#'
#' @return No object is returned. This function takes in objects of class 'fosr' and outputs a shiny application for that object.

plot_shiny.fosr = function(obj, xlab = "", ylab="", title = "", ...) {

  fosr.obj <- obj

  ### NULLify global values called in ggplot
  value = subj = covariate = UB = LB = residual = depth.rank = coef = grid = x = y = NULL

  ################################
  ## code for processing tabs
  ################################

  p = dim(fosr.obj$beta.hat)[1]
  D = dim(fosr.obj$beta.hat)[2]
  grid = 1:D

  ## Tab 1: covariate choice
  covar.list = names(attributes(terms(fosr.obj$terms))$dataClasses)
  covar.list[1] = "None"
  covarInputValues = 1:length(covar.list)
  names(covarInputValues) = covar.list
  spaghetti.help = "Observed response data, colored according to the covariate selected below."
  spaghetti.call = eval(call("selectInput", inputId = "CovarChoice", label = ("Select Covariate"), choices = covarInputValues, selected = 1))
  lasagna.help = "Observed response data, each row is a subject. When a covariate is selected, the rows are ordered and widths
                are assigned by value of that covariate. Right plot displays distribution of covariate selected in
                correspondence with ordering of the rows at right."
  lasagna.call = eval(call("selectInput", inputId = "CovarChoice2", label = ("Select Covariate"), choices = covarInputValues, selected = 1))


  ## Tab 2: fitted values
  pred.list = names(attributes(terms(fosr.obj$terms))$dataClasses)[-1]
  fitted.help = "Fitted response curve for a subject with covariate values specified below."
  fitted.call <- vector("list", length(pred.list))
  for(i in 1:length(pred.list)){
    fitted.call[[i]] =  eval(createInputCall(pred.list[i], get(pred.list[i], fosr.obj$data) ))
  }

  ## Tab 3: coefficient functions
  coef.list = colnames(model.matrix(fosr.obj$terms, fosr.obj$data[1,]))
  coefInputValues = 1:p
  names(coefInputValues) = coef.list
  coef.help = "Coefficient function for the predictor selected below."
  coef.call = eval(call("selectInput", inputId = "CoefChoice", label = ("Select Predictor"), choices = coefInputValues, selected = 1))

  ## Tab 4: plot of residual curves
  residuals.help = "If 'Show Outliers' is selected, the median and outlying curves are shown in blue and red respectively. If 'Rainbowize'
                    is selected, curves are ordered by band depth with most outlying curves shown in red and
                    curves closest to the median shown in violet."
  residuals.call = eval(call("radioButtons","residOptions", label="Plot Options",
                             choices = list("None"=1, "Show Median and Outliers"=2,"Rainbowize by Depth"=3), selected=1))

  #################################
  ## App
  #################################

  shinyApp(

  #################################
  ## UI
  #################################

    ui = navbarPage(title = strong(style = "color: #ACD6FF; padding: 0px 0px 10px 10px; opacity: 0.95; ", "FoSR Plot"),
                    windowTitle = "refund.shiny", collapsible = FALSE, id = "nav", inverse = TRUE, header = NULL,
                    ##### start tabs
                    tabPanel("Observed Data", icon = icon("stats", lib = "glyphicon"),
                             tabsetPanel(
                               tabPanelModuleUI("spaghetti", tabTitle = "Spaghetti Plot", calls = spaghetti.call,
                                                helperText = spaghetti.help),
                               tabPanelModuleUI("lasagna", tabTitle = "Lasagna Plot", calls = lasagna.call,
                                                helperText = lasagna.help)
                             ) ),
                    tabPanelModuleUI("fitted", tabTitle = "Fitted Values", icon("chart-line"), calls = fitted.call,helperText = fitted.help ),
                    tabPanelModuleUI("coef", tabTitle = "Coefficient Functions", icon("chart-area"), calls = coef.call, helperText = coef.help),
                    tabPanelModuleUI("residuals", tabTitle = "Residuals", icon("medkit"), calls = residuals.call,helperText = residuals.help )
                    ##### end tabs
                    ),

    #################################
    ## Server
    #################################

    server = function(input, output){

      #################################
      ## Code for observed data tab
      #################################

      plotInputSpagheti <- reactive({
        y.obs = fosr.obj$data[,names(attributes(terms(fosr.obj$terms))$dataClasses)[1]]
        colnames(y.obs) = grid
        y.obs.m = melt(y.obs)
        colnames(y.obs.m) = c("subj", "grid", "value")

        CovarChoice = as.numeric(input$CovarChoice)
        selected = covar.list[CovarChoice]
        if(selected == "None") {
          y.obs.m$covariate = NULL
        } else {
           y.obs.m$covariate = rep(fosr.obj$data[,selected], length(grid))
        }
        #y.obs.m

        if(is.null(y.obs.m$covariate)){
          p1 <- ggplot(y.obs.m, aes(x=grid, y=value, group = subj)) + geom_line(alpha = .3, color="black") +
            theme_bw() + xlab("") + ylab("")
        } else {
          p1 <- ggplot(y.obs.m, aes(x=grid, y=value, group = subj, color = covariate)) + geom_line(alpha = .3) +
            theme_bw() + xlab("") + ylab("") + theme(legend.position="bottom", legend.title=element_blank())
        }
      })


      plotInputLasagna = reactive({
        y.obs.char = as.character(fosr.obj$terms[[2]]) ## gets character string which is name of outcome variable

        CovarChoice2 = as.numeric(input$CovarChoice2)
        selected = covar.list[CovarChoice2]
        if(selected == "None") {
         covariate = NULL
        }
        else if(length(table(fosr.obj$data[, selected])) < 3){
          fosr.obj$data[, selected] = factor(fosr.obj$data[, selected])
          covariate = selected
        }
        else {
         covariate = selected
        }

        df = makeLasagna(data = fosr.obj$data, outcome = y.obs.char, covariate = covariate)
        plots = bakeLasagna(data = fosr.obj$data, data.long = df$data.long, covariate = covariate)

        grid.arrange(plots$lasagnaPlot, plots$densityPlot, ncol=2, nrow=1, widths=c(4, 1))
      })

      callModule(tabPanelModule, "spaghetti", plotObject = plotInputSpagheti, plotName = "spaghetti")
      callModule(tabPanelModule, "lasagna", plotObject = plotInputLasagna, plotName = "lasagna", is.grid = TRUE)

      #################################
      ## Code for FittedValues Tab
      #################################

      plotInputFittedVal <- reactive({

        variables = sapply(pred.list, function(u) {input[[u]]})

        input.data = fosr.obj$data[1,]

        reassign = function(var, newdata){
          if(is.numeric(fosr.obj$data[,var])){
            var.value = as.numeric(newdata[var])
            #          } else if(is.factor(fosr.obj$data[,var]) & length(levels(fosr.obj$data[,var])) <=2){
            #            var.value = factor(levels(fosr.obj$data[,var])[newdata[var]+1], levels = levels(fosr.obj$data[,var]))
          } else if(is.factor(fosr.obj$data[,var])){
            var.value = factor(newdata[var], levels = levels(fosr.obj$data[,var]))
          }
          var.value
        }

        input.data[,pred.list] = lapply(pred.list, reassign, variables)

        X.design = t(matrix(model.matrix(fosr.obj$terms, input.data)))
        fit.vals = as.vector(X.design %*% fosr.obj$beta.hat)
        df <- data.frame(grid = grid,
                   fit.vals = fit.vals)

        p2 <- ggplot(df, aes(x = grid, y = fit.vals)) + geom_line(lwd=1) + theme_bw() +
          xlab(xlab) + ylab(ylab) + ylim(c(.9, 1.1) * range(fosr.obj$Yhat))

      })

      callModule(tabPanelModule, "fitted", plotObject = plotInputFittedVal, plotName = "fitted")

      #################################
      ## Code for CoefFunc Tab
      #################################

      plotInputCoefFunc <- reactive({
        CoefChoice = as.numeric(input$CoefChoice)
        df <- data.frame(grid = grid,
                   coef = fosr.obj$beta.hat[CoefChoice,],
                   UB =  fosr.obj$beta.UB[CoefChoice,],
                   LB = fosr.obj$beta.LB[CoefChoice,])

        p3 <- ggplot(df, aes(x=grid, y=coef))+geom_line(linetype=1, lwd=1.5, color="black")+
          geom_line(data = df, aes(y=UB), color = "blue") +
          geom_line(data = df, aes(y=LB), color = "blue")+
          theme_bw() + xlab("") + ylab("")

      })


      callModule(tabPanelModule, "coef", plotObject = plotInputCoefFunc, plotName = "coef")

      #################################
      ## Code for Residual plot
      #################################

      response = fosr.obj$data[,names(attributes(terms(fosr.obj$terms))$dataClasses)[1]]
      resid = response - fosr.obj$Yhat
      colnames(resid) = grid
      outs = outliers(resid, 1.5) # detects outliers
      resid.m = melt(resid)
      colnames(resid.m) = c("subj", "grid", "residual")
      resid.m = resid.m[order(resid.m$subj),]
      resid.m$depths = rep(outs$depth, each = dim(resid)[2])
      resid.m = resid.m[order(resid.m$depths, decreasing = FALSE),]
      resid.m$depth.rank = rep(1:dim(resid)[1], each=dim(resid)[2])


      # residuals for outliers

      resid.outs.m = melt(outs$outcurves)
      colnames(resid.outs.m) = c("subj", "grid", "residual")

      # residuals for median curve
      resid.med.m = melt(outs$medcurve)
      colnames(resid.med.m) = c("subj", "grid", "residual")

       plotInputResid <- reactive({
        residPlot = ggplot(resid.m, aes(x=grid, y=residual, group = subj))+ theme_bw() + geom_line(alpha = .3, color="black")

        if(input$residOptions==2 & dim(outs$outcurves)[1]!= 0){residPlot=residPlot+
                                   geom_line(data=resid.outs.m, aes(x=grid, y=residual, group=subj, color="outliers"))+
                                   geom_line(data=resid.med.m, aes(x=grid, y=residual, group=subj, color = "median"))+
                                   scale_colour_manual("", values = c("outliers"="indianred", "median"="blue"), guide = FALSE)
                                   #theme(legend.position="bottom")

        }
        else if(input$residOptions==2 & dim(outs$outcurves)[1]== 0){residPlot=residPlot+
                                   geom_line(data=resid.med.m, aes(x=grid, y=residual, group=subj, color = "median"))+
                                   scale_colour_manual("", values = c("median"="blue"), guide=FALSE)

        }

        else if (input$residOptions == 3){residPlot = ggplot(resid.m, aes(x=grid, y=residual, group = subj)) +
                                             geom_line(aes(color=factor(depth.rank))) + theme_bw()+ theme(legend.position="none")}
        residPlot  + xlab("") + ylab("")
      })

       callModule(tabPanelModule, "residuals", plotObject = plotInputResid, plotName = "residuals")

      ## add subject number

    } ## end server
  )
}

Try the refund.shiny package in your browser

Any scripts or data that you put into this service are public.

refund.shiny documentation built on Oct. 11, 2022, 1:05 a.m.