从“openair”包中的风玫瑰中删除默认标题

Question

我使用“openair”包创建了一个风玫瑰图，用于获取水流和方向数据。 但是，默认标题应用于“风向计数频率 (%)”图，这不适用于水流数据。我无法删除标题 - 谁能帮忙？

 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)

谢谢！

Answer 1

还有另一种方法，不涉及复制整个函数。

如果您检查 windRose 代码，您可以看到标题是根据 statistic 选项的值设置的。在文档中你可以看到官方的选项是“prop.count”、“prop.mean”、“abs.count”和“frequency”；但代码还会检查传递给统计选项的参数是否为列表，并根据列表内容设置统计选项：

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
}

您要更改的标题由 statistic$lab 定义

通过将列表传递给统计选项，您可以设置标题等。因此，更改标题的一种简单方法是将列表传递给统计选项，其中包含从官方选项之一复制的所有内容并更改标题。例如，假设我想使用带有自定义标题的“prop.count”。然后我会转换代码中列出的选项：

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)

进入标题（实验室）已更改的命名列表：

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))

并在对windRose的调用中使用它：

windRose(mydata,statistic=my.statistic)

Answer 2

很多 R 函数的优点在于，在许多情况下，您可以输入它们的名称来查看源代码。所以在这里你可以输入windRose，然后编辑所需的标签如下：

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)
}

这里我复制了整个源代码，并创建了一个新函数 windRose.2，唯一的区别是 stat.lab <- "Frequency of counts by wind direction (%)" 现在是 stat.lab <- ""。