Removing default title from wind rose in 'openair' package

Question

I have created a wind rose using the package 'openair', for water current and direction data. However, a default title is applied to the plot "Frequency of counts by wind direction (%)" which is not applicable to water current data. I cannot remove the title - can anyone help?

 windRose(Wind, ws = "ws", wd = "wd", ws2 = NA, wd2 =NA, 
ws.int = 20, angle = 10, type = "default", cols ="increment", 
grid.line = NULL, width = 0.5, seg = NULL,
auto.text = TRUE, breaks = 5, offset = 10, paddle =FALSE, 
key.header = "Current Speed", key.footer = "(cm/s)",
key.position = "right", key = TRUE, dig.lab = 3,
statistic = "prop.count", pollutant = NULL, annotate =
TRUE, border = NA, na.action=NULL)

Thanks!

Answer 1

The great thing about a lot of R functions is you can type their name to see the source, in many cases. So here you could type windRose, and edit the required label as below:

windRose.2 <- function (mydata, ws = "ws", wd = "wd", ws2 = NA, wd2 = NA, ws.int = 2, 
    angle = 30, type = "default", cols = "default", grid.line = NULL, 
    width = 1, seg = NULL, auto.text = TRUE, breaks = 4, offset = 10, 
    paddle = TRUE, key.header = NULL, key.footer = "(m/s)", key.position = "bottom", 
    key = TRUE, dig.lab = 5, statistic = "prop.count", pollutant = NULL, 
    annotate = TRUE, border = NA, ...) 
{
    if (is.null(seg)) 
        seg <- 0.9
    if (length(cols) == 1 && cols == "greyscale") {
        trellis.par.set(list(strip.background = list(col = "white")))
        calm.col <- "black"
    }
    else {
        calm.col <- "forestgreen"
    }
    current.strip <- trellis.par.get("strip.background")
    on.exit(trellis.par.set("strip.background", current.strip))
    if (360/angle != round(360/angle)) {
        warning("In windRose(...):\n  angle will produce some spoke overlap", 
            "\n  suggest one of: 5, 6, 8, 9, 10, 12, 15, 30, 45, etc.", 
            call. = FALSE)
    }
    if (angle < 3) {
        warning("In windRose(...):\n  angle too small", "\n  enforcing 'angle = 3'", 
            call. = FALSE)
        angle <- 3
    }
    extra.args <- list(...)
    extra.args$xlab <- if ("xlab" %in% names(extra.args)) 
        quickText(extra.args$xlab, auto.text)
    else quickText("", auto.text)
    extra.args$ylab <- if ("ylab" %in% names(extra.args)) 
        quickText(extra.args$ylab, auto.text)
    else quickText("", auto.text)
    extra.args$main <- if ("main" %in% names(extra.args)) 
        quickText(extra.args$main, auto.text)
    else quickText("", auto.text)
    if (is.character(statistic)) {
        ok.stat <- c("prop.count", "prop.mean", "abs.count", 
            "frequency")
        if (!is.character(statistic) || !statistic[1] %in% ok.stat) {
            warning("In windRose(...):\n  statistic unrecognised", 
                "\n  enforcing statistic = 'prop.count'", call. = FALSE)
            statistic <- "prop.count"
        }
        if (statistic == "prop.count") {
            stat.fun <- length
            stat.unit <- "%"
            stat.scale <- "all"
            stat.lab <- ""
            stat.fun2 <- function(x) signif(mean(x, na.rm = TRUE), 
                3)
            stat.lab2 <- "mean"
            stat.labcalm <- function(x) round(x, 1)
        }
        if (statistic == "prop.mean") {
            stat.fun <- function(x) sum(x, na.rm = TRUE)
            stat.unit <- "%"
            stat.scale <- "panel"
            stat.lab <- "Proportion contribution to the mean (%)"
            stat.fun2 <- function(x) signif(mean(x, na.rm = TRUE), 
                3)
            stat.lab2 <- "mean"
            stat.labcalm <- function(x) round(x, 1)
        }
        if (statistic == "abs.count" | statistic == "frequency") {
            stat.fun <- length
            stat.unit <- ""
            stat.scale <- "none"
            stat.lab <- "Count by wind direction"
            stat.fun2 <- function(x) round(length(x), 0)
            stat.lab2 <- "count"
            stat.labcalm <- function(x) round(x, 0)
        }
    }
    if (is.list(statistic)) {
        stat.fun <- statistic$fun
        stat.unit <- statistic$unit
        stat.scale <- statistic$scale
        stat.lab <- statistic$lab
        stat.fun2 <- statistic$fun2
        stat.lab2 <- statistic$lab2
        stat.labcalm <- statistic$labcalm
    }
    vars <- c(wd, ws)
    diff <- FALSE
    rm.neg <- TRUE
    if (!is.na(ws2) & !is.na(wd2)) {
        vars <- c(vars, ws2, wd2)
        diff <- TRUE
        rm.neg <- FALSE
        mydata$ws <- mydata[, ws2] - mydata[, ws]
        mydata$wd <- mydata[, wd2] - mydata[, wd]
        id <- which(mydata$wd < 0)
        if (length(id) > 0) 
            mydata$wd[id] <- mydata$wd[id] + 360
        pollutant <- "ws"
        key.footer <- "ws"
        wd <- "wd"
        ws <- "ws"
        vars <- c("ws", "wd")
        if (missing(angle)) 
            angle <- 10
        if (missing(offset)) 
            offset <- 20
        if (is.na(breaks[1])) {
            max.br <- max(ceiling(abs(c(min(mydata$ws, na.rm = TRUE), 
                max(mydata$ws, na.rm = TRUE)))))
            breaks <- c(-1 * max.br, 0, max.br)
        }
        if (missing(cols)) 
            cols <- c("lightskyblue", "tomato")
        seg <- 1
    }
    if (any(type %in% openair:::dateTypes)) 
        vars <- c(vars, "date")
    if (!is.null(pollutant)) 
        vars <- c(vars, pollutant)
    mydata <- openair:::checkPrep(mydata, vars, type, remove.calm = FALSE, 
        remove.neg = rm.neg)
    mydata <- na.omit(mydata)
    if (is.null(pollutant)) 
        pollutant <- ws
    mydata$x <- mydata[, pollutant]
    mydata[, wd] <- angle * ceiling(mydata[, wd]/angle - 0.5)
    mydata[, wd][mydata[, wd] == 0] <- 360
    mydata[, wd][mydata[, ws] == 0] <- -999
    if (length(breaks) == 1) 
        breaks <- 0:(breaks - 1) * ws.int
    if (max(breaks) < max(mydata$x, na.rm = TRUE)) 
        breaks <- c(breaks, max(mydata$x, na.rm = TRUE))
    if (min(breaks) > min(mydata$x, na.rm = TRUE)) 
        warning("Some values are below minimum break.")
    breaks <- unique(breaks)
    mydata$x <- cut(mydata$x, breaks = breaks, include.lowest = FALSE, 
        dig.lab = dig.lab)
    theLabels <- gsub("[(]|[)]|[[]|[]]", "", levels(mydata$x))
    theLabels <- gsub("[,]", " to ", theLabels)
    prepare.grid <- function(mydata) {
        if (all(is.na(mydata$x))) 
            return()
        levels(mydata$x) <- c(paste("x", 1:length(theLabels), 
            sep = ""))
        all <- stat.fun(mydata[, wd])
        calm <- mydata[mydata[, wd] == -999, ][, pollutant]
        mydata <- mydata[mydata[, wd] != -999, ]
        calm <- stat.fun(calm)
        weights <- tapply(mydata[, pollutant], list(mydata[, 
            wd], mydata$x), stat.fun)
        if (stat.scale == "all") {
            calm <- calm/all
            weights <- weights/all
        }
        if (stat.scale == "panel") {
            temp <- stat.fun(stat.fun(weights)) + calm
            calm <- calm/temp
            weights <- weights/temp
        }
        weights[is.na(weights)] <- 0
        weights <- t(apply(weights, 1, cumsum))
        if (stat.scale == "all" | stat.scale == "panel") {
            weights <- weights * 100
            calm <- calm * 100
        }
        panel.fun <- stat.fun2(mydata[, pollutant])
        u <- mean(sin(2 * pi * mydata[, wd]/360))
        v <- mean(cos(2 * pi * mydata[, wd]/360))
        mean.wd <- atan2(u, v) * 360/2/pi
        if (all(is.na(mean.wd))) {
            mean.wd <- NA
        }
        else {
            if (mean.wd < 0) 
                mean.wd <- mean.wd + 360
            if (mean.wd > 180) 
                mean.wd <- mean.wd - 360
        }
        weights <- cbind(data.frame(weights), wd = as.numeric(row.names(weights)), 
            calm = calm, panel.fun = panel.fun, mean.wd = mean.wd)
        weights
    }
    if (paddle) {
        poly <- function(wd, len1, len2, width, colour, x.off = 0, 
            y.off = 0) {
            theta <- wd * pi/180
            len1 <- len1 + off.set
            len2 <- len2 + off.set
            x1 <- len1 * sin(theta) - width * cos(theta) + x.off
            x2 <- len1 * sin(theta) + width * cos(theta) + x.off
            x3 <- len2 * sin(theta) - width * cos(theta) + x.off
            x4 <- len2 * sin(theta) + width * cos(theta) + x.off
            y1 <- len1 * cos(theta) + width * sin(theta) + y.off
            y2 <- len1 * cos(theta) - width * sin(theta) + y.off
            y3 <- len2 * cos(theta) + width * sin(theta) + y.off
            y4 <- len2 * cos(theta) - width * sin(theta) + y.off
            lpolygon(c(x1, x2, x4, x3), c(y1, y2, y4, y3), col = colour, 
                border = border)
        }
    }
    else {
        poly <- function(wd, len1, len2, width, colour, x.off = 0, 
            y.off = 0) {
            len1 <- len1 + off.set
            len2 <- len2 + off.set
            theta <- seq((wd - seg * angle/2), (wd + seg * angle/2), 
                length.out = (angle - 2) * 10)
            theta <- ifelse(theta < 1, 360 - theta, theta)
            theta <- theta * pi/180
            x1 <- len1 * sin(theta) + x.off
            x2 <- rev(len2 * sin(theta) + x.off)
            y1 <- len1 * cos(theta) + x.off
            y2 <- rev(len2 * cos(theta) + x.off)
            lpolygon(c(x1, x2), c(y1, y2), col = colour, border = border)
        }
    }
    mydata <- cutData(mydata, type, ...)
    results.grid <- ddply(mydata, type, prepare.grid)
    results.grid$calm <- stat.labcalm(results.grid$calm)
    results.grid$mean.wd <- stat.labcalm(results.grid$mean.wd)
    strip.dat <- openair:::strip.fun(results.grid, type, auto.text)
    strip <- strip.dat[[1]]
    strip.left <- strip.dat[[2]]
    pol.name <- strip.dat[[3]]
    if (length(theLabels) < length(cols)) {
        col <- cols[1:length(theLabels)]
    }
    else {
        col <- openColours(cols, length(theLabels))
    }
    max.freq <- max(results.grid[, (length(type) + 1):(length(theLabels) + 
        length(type))], na.rm = TRUE)
    off.set <- max.freq * (offset/100)
    box.widths <- seq(0.002^0.25, 0.016^0.25, length.out = length(theLabels))^4
    box.widths <- box.widths * max.freq * angle/5
    legend <- list(col = col, space = key.position, auto.text = auto.text, 
        labels = theLabels, footer = key.footer, header = key.header, 
        height = 0.6, width = 1.5, fit = "scale", plot.style = if (paddle) "paddle" else "other")
    legend <- openair:::makeOpenKeyLegend(key, legend, "windRose")
    temp <- paste(type, collapse = "+")
    myform <- formula(paste("x1 ~ wd | ", temp, sep = ""))
    mymax <- 2 * max.freq
    myby <- if (is.null(grid.line)) 
        pretty(c(0, mymax), 10)[2]
    else grid.line
    if (myby/mymax > 0.9) 
        myby <- mymax * 0.9
    xyplot.args <- list(x = myform, xlim = 1.03 * c(-max.freq - 
        off.set, max.freq + off.set), ylim = 1.03 * c(-max.freq - 
        off.set, max.freq + off.set), data = results.grid, type = "n", 
        sub = stat.lab, strip = strip, strip.left = strip.left, 
        as.table = TRUE, aspect = 1, par.strip.text = list(cex = 0.8), 
        scales = list(draw = FALSE), panel = function(x, y, subscripts, 
            ...) {
            panel.xyplot(x, y, ...)
            angles <- seq(0, 2 * pi, length = 360)
            sapply(seq(off.set, mymax, by = myby), function(x) llines(x * 
                sin(angles), x * cos(angles), col = "grey85", 
                lwd = 1))
            subdata <- results.grid[subscripts, ]
            upper <- max.freq + off.set
            larrows(-upper, 0, upper, 0, code = 3, length = 0.1)
            larrows(0, -upper, 0, upper, code = 3, length = 0.1)
            ltext(upper * -1 * 0.95, 0.07 * upper, "W", cex = 0.7)
            ltext(0.07 * upper, upper * -1 * 0.95, "S", cex = 0.7)
            ltext(0.07 * upper, upper * 0.95, "N", cex = 0.7)
            ltext(upper * 0.95, 0.07 * upper, "E", cex = 0.7)
            if (nrow(subdata) > 0) {
                for (i in 1:nrow(subdata)) {
                  with(subdata, {
                    for (j in 1:length(theLabels)) {
                      if (j == 1) {
                        temp <- "poly(wd[i], 0, x1[i], width * box.widths[1], col[1])"
                      } else {
                        temp <- paste("poly(wd[i], x", j - 1, 
                          "[i], x", j, "[i], width * box.widths[", 
                          j, "], col[", j, "])", sep = "")
                      }
                      eval(parse(text = temp))
                    }
                  })
                }
            }
            ltext(seq((myby + off.set), mymax, myby) * sin(pi/4), 
                seq((myby + off.set), mymax, myby) * cos(pi/4), 
                paste(seq(myby, mymax, by = myby), stat.unit, 
                  sep = ""), cex = 0.7)
            if (annotate) if (statistic != "prop.mean") {
                if (!diff) {
                  ltext(max.freq + off.set, -max.freq - off.set, 
                    label = paste(stat.lab2, " = ", subdata$panel.fun[1], 
                      "\ncalm = ", subdata$calm[1], stat.unit, 
                      sep = ""), adj = c(1, 0), cex = 0.7, col = calm.col)
                }
                if (diff) {
                  ltext(max.freq + off.set, -max.freq - off.set, 
                    label = paste("mean ws = ", round(subdata$panel.fun[1], 
                      1), "\nmean wd = ", round(subdata$mean.wd[1], 
                      1), sep = ""), adj = c(1, 0), cex = 0.7, 
                    col = calm.col)
                }
            } else {
                ltext(max.freq + off.set, -max.freq - off.set, 
                  label = paste(stat.lab2, " = ", subdata$panel.fun[1], 
                    stat.unit, sep = ""), adj = c(1, 0), cex = 0.7, 
                  col = calm.col)
            }
        }, legend = legend)
    xyplot.args <- openair:::listUpdate(xyplot.args, extra.args)
    plt <- do.call(xyplot, xyplot.args)
    if (length(type) == 1) 
        plot(plt)
    else plot(useOuterStrips(plt, strip = strip, strip.left = strip.left))
    newdata <- results.grid
    output <- list(plot = plt, data = newdata, call = match.call())
    class(output) <- "openair"
    invisible(output)
}

Here I've copied the entire source, and made a new function, windRose.2 with the only difference being stat.lab <- "Frequency of counts by wind direction (%)" is now stat.lab <- "".

Answer 2

There is another way that does not involve copying the whole function.

If you inspect the windRose code you can see that the title is set according to the value of the statistic option. In the documentation you can see that the oficial options are "prop.count", "prop.mean", "abs.count" and "frequency"; but code also checks if the argument passed to the statistic option is a list and sets the statistic options according to the list contents:

if (is.list(statistic)) {
    stat.fun <- statistic$fun
    stat.unit <- statistic$unit
    stat.scale <- statistic$scale
    stat.lab <- statistic$lab
    stat.fun2 <- statistic$fun2
    stat.lab2 <- statistic$lab2
    stat.labcalm <- statistic$labcalm
}

the title that you want to change is defined by statistic$lab

By passing a list to the statistic option you can set among others, the title. So, an easy way to change the title is to pass a list to the statistic option with everything copied from one of the oficial options and changing the title. For example, let's say that I want to use "prop.count" with a custom title. Then I'd transform the options listed in the code:

stat.fun <- length
        stat.unit <- "%"
        stat.scale <- "all"
        stat.lab <- "Frequency of counts by wind direction (%)"
        stat.fun2 <- function(x) signif(mean(x, na.rm = TRUE), 
            3)
        stat.lab2 <- "mean"
        stat.labcalm <- function(x) round(x, 1)

into a named list with the title (lab) changed:

my.statistic <- list("fun"=length,"unit" = "%","scale" = "all", "lab" = "My title" , "fun2" = function(x) signif(mean(x, na.rm = TRUE), 3), "lab2" = "mean","labcalm" = function(x) round(x, 1))

and use it in the call to windRose:

windRose(mydata,statistic=my.statistic)