R/plot_templates.r

In ptompalski/UsefulRFunctions: A personal set of R tools.

#' Custom ggplot template
#'
#' @param base_size Optional font size.
#' @param base_family Optional font name.
#' @return A ggplot template.
#' @aliases bw
#' @export


theme_pt <- function(base_size = 12, base_family = "") {
  ggplot2::theme_bw(base_size = base_size, base_family = base_family) + #%+replace%
    ggplot2::theme(
      #panel.border = ggplot2::element_rect(colour = "black", fill = F, size = 1),
      axis.text = ggplot2::element_text(margin = ggplot2::margin(10,10,10,10)),
      plot.margin = grid::unit(c(1.2, 1.2, 1.2, 1.2), "lines"),
      axis.ticks.length= grid::unit(0.15,"cm"),
      panel.grid.major = ggplot2::element_blank(),
      panel.grid.minor = ggplot2::element_blank(),
      panel.border = ggplot2::element_rect(colour = "black", fill = F, size = 1),
      legend.key = ggplot2::element_blank(),
      axis.title.x = ggplot2::element_text(margin = ggplot2::margin(10,0,0,0)),#element_text(hjust=0.5,vjust=0.5),
      axis.title.y = ggplot2::element_text(margin = ggplot2::margin(0,10,0,0),angle=90),#(hjust=0.5,vjust=1.5,angle=90),
      #strip.background = ggplot2::element_blank(),
      strip.text = ggplot2::element_text(lineheight=1.5),
      strip.background = ggplot2::element_blank(),#no border for facet titles
      legend.position="bottom", # legend on bottom
      legend.title = ggplot2::element_blank () #no title for legend
    )
}
bw <- theme_pt()



#' scatterplot with optional information on the errors between x and y.
#'
#' @param x a vector of observed data.
#' @param y a vector of predicted data.
#' @param by optional grouping variable. Can be character or factor
#' @param axisorder Optional. Set to \code{PO} (predicted-observed) to plot predicted (\code{y}) on the y-axis (this is the default). Set to \code{OP} (observed-predicted) to plot observed (\code{x}) on the y-axis.
#' @param xlab Optional. Title of the x-axis
#' @param ylab Optional. Title of the y-axis
#' @param info A logical value indictating whether information on count, bias and RMSE should be added to the plot.
#' @param position Determines the position of the info box
#' @param positionauto A logical value indicating whether the position of the info box should be optimized automaticaly.
#' @param lowerlimit A value determining the lower limit of the x and y axis
#' @param upperlimit A value determining the upper limit of the x and y axis
#' @param alpha Define the transparency of the points. 0 - fully transparent, 1 - opaque.
#' @param add.reg.line Logical. Should the regression line be added to the plot? Regression coeficients are calculated automatically.
#' @param rug Logical. Add marginal rug to the plot.
#' @param label_text A character vector of length=5 defining the names for the values in the info box.
#' @return a scatterplot of \code{x} and \code{y}.
#' @description This scatterplot is a wrapper function for a ggplot-based plot. It containes additional text panel that shows values calculated with \code{\link{calc.error}}
#' @examples
#' x <- iris$Sepal.Length
#' y <- predict(lm(data=iris,iris$Sepal.Length~iris$Petal.Width))
#' scatter(x,y)
#' @export

scatter <- function(x,y,by=NULL,axisorder="PO",
                    xlab="Observed",ylab="Predicted",
                    title=NULL,info=T,
                    position=0,positionauto=T,
                    lowerlimit=NA,upperlimit=NA,
                    alpha=1,add.reg.line=F ,rug=F,
                    label_text = c("n","bias","bias%","RMSE","RMSE%")) {
  if (!is.null(by)) {
    data <- data.frame(x=x,y=y,by=by)
    pts <- ggplot2::geom_point(shape=1,size=2,alpha=alpha,ggplot2::aes(colour=by))
  } else {
    data <- data.frame(x=x,y=y)
    pts <- ggplot2::geom_point(shape=1,size=2,alpha=alpha)
  }

  d <- UsefulRFunctions::calc.error(reference = data$x,estimate = data$y)

  label <- paste(label_text[1]," = ",d$count,
                 "\n",label_text[2]," = ",round(d$bias,3),
                 "\n",label_text[3]," = ",round(d$bias_perc,2),
                 "\n",label_text[4]," = ",round(d$RMSE,3),
                 "\n",label_text[5]," = ",round(d$RMSE_perc,2),
                 sep="")

  if(axisorder == "OP") {
    data <- data.frame(x=data$y,y=data$x)
    x_lab_copy <- xlab
    xlab=ylab
    ylab=x_lab_copy
  }

  if (is.na(lowerlimit))  lowerlimit <- min(data[c("x","y")],na.rm=T)
  if (is.na(upperlimit))  upperlimit <- max(data[c("x","y")],na.rm=T)

  if(position != 0) positionauto <- F
  if(positionauto == T) {
    if (is.finite(d$bias_perc) & d$bias_perc < -20) position <- 1
  }

  if(position == 0)  {ann_x <- upperlimit; ann_y <- -Inf; ann_hjust <- 1; ann_vjust <- -0.2}
  if(position == 1)  {ann_x <- lowerlimit; ann_y <- upperlimit; ann_hjust <- 0; ann_vjust <- 0.9}

  if (info==T) {ann <- ggplot2::annotate("text",x=ann_x,y=ann_y,label=label,hjust=ann_hjust,vjust=ann_vjust)} else {ann<-bw}
  if (rug==T) {addrug <- ggplot2::geom_rug(alpha=0.2)} else {addrug <-bw}
  if (add.reg.line==T) {reg.line <- ggplot2::geom_smooth(se = FALSE,method="lm",colour="red")} else {reg.line <- bw}

  plot <- ggplot2::ggplot(data=data,ggplot2::aes(x=x,y=y))  +
    pts +
    ggplot2::xlab(xlab)+
    ggplot2::ylab(ylab)+
    ggplot2::ggtitle(title) +
    ggplot2::xlim(lowerlimit,upperlimit) +
    ggplot2::ylim(lowerlimit,upperlimit) +
    ggplot2::geom_abline(intercept=0,slope=1)+
    ann+
    ggplot2::theme(legend.position='bottom')+
    ggplot2::coord_equal(ratio =1) +
    addrug +
    reg.line +
    UsefulRFunctions:::bw

  return(plot)
}



#' Custom histogram with additional descriptive stats
#'
#' @param x a vector
#' @param binwidth Optional. width of a histogram bin.
#' @param ylab Optional. Y-axis label.
#' @param xlab Optional. X-axis label.
#' @param lowerlimit Optional. Lower limit of the histogram
#' @param upperlimit Optional. Upper limit of the histogram
#' @param info Optional. Logical - should the descriptive stats be ploted?
#' @param density Optional. Logical - Plot density plot instead of histogram.
#' @param perc Optional. Logical - Should the counts for each bin be converted to percent?
#' @param fontize Optional. Fontsize of the plot text elements.
#' @param text_horizontal_position Optional. Horizontal position of the info box. Default = "right". Can be "left" or a numerical value indicating the position of the left side of the box.
#' @param fill_color Color of the histogram bars.
#' @description This custom histogram is a wrapper function for a custiomized ggplot generated histogram. Additional descriptive statistics are calculated with function \code{\link{des}}.

#' @return histogram of \code{x}
#' @examples
#' h(iris$Sepal.Length)
#' @export

h <- function(x,
              binwidth=NULL,
              xlab=NULL,
              ylab="count",
              lowerlimit=NA,
              upperlimit=NA,
              info=T,
              density=F,
              perc=F,
              fontsize=4,
              text_horizontal_position = "right",
              fill_color = "#d3d3d3") {

  plot_theme <- theme_pt()

  if (!is.na(upperlimit)) {
    x <- x[x <= upperlimit]
  }
  if (!is.na(lowerlimit)) {
    x <- x[x >= lowerlimit]
  }

  d <- UsefulRFunctions::des(x)

  label <- paste("n = ",d$n,
                 "\nMean = ",round(d$Mean,2),
                 "\nMedian = ",round(d$Median,2),
                 "\nStd.Dev = ",round(d$Std.Dev,2),
                 "\nMin = ",round(d$Min,2),
                 "\nMax = ",round(d$Max,2),
                 sep="")




  if (tolower(text_horizontal_position) %in% c("right","r")) {
    upperlimit_ann <- max(x,na.rm=T)
    ann_x <- upperlimit_ann; ann_y <-Inf; ann_hjust <- 1; ann_vjust <- 1.2
  } else if (tolower(text_horizontal_position) %in% c("left","l")) {
    upperlimit_ann <- min(x,na.rm=T)
    ann_x <- upperlimit_ann; ann_y <-Inf; ann_hjust <- 0; ann_vjust <- 1.2
  } else if (is.numeric(text_horizontal_position)) {
    upperlimit_ann <- text_horizontal_position
    ann_x <- upperlimit_ann; ann_y <-Inf; ann_hjust <- 0; ann_vjust <- 1.2
  }

  if (info == T) {ann <- ggplot2::annotate("text",x=ann_x,y=ann_y,label=label,hjust=ann_hjust,vjust=ann_vjust,size=fontsize)} else {ann<-bw}

  if(perc == T) {
    plot.hist <- ggplot2::geom_bar(ggplot2::aes(y = (..count..)/sum(..count..)),
                                   colour="black",fill=fill_color,
                                   position = position_dodge(width = 1))
  } else {
    if(density == F) {
      plot.hist <- ggplot2::geom_histogram(binwidth=binwidth,colour="black",fill=fill_color)
    } else {
      plot.hist <- ggplot2::geom_density(colour="black",fill=fill_color)
    }
  }

  plot <- ggplot2::ggplot(data=NULL,ggplot2::aes(x=x))+
    plot_theme +
    plot.hist+
    ggplot2::xlab(xlab)+
    ggplot2::ylab(ylab)+
    ann#+
    #ggplot2::xlim(lowerlimit,upperlimit)

  return(plot)
}