Whig 发表于 2019-8-9 09:29 
你的代码呢？
function (mydata, pollutant = "nox", year = 2003, month = 1:12,
type = "default", annotate = "date", statistic = "mean",
cols = "heat", limits = c(0, 100), lim = NULL, col.lim = c("grey30",
"black"), col.arrow = "black", font.lim = c(1, 2), cex.lim = c(0.6,
1), digits = 0, data.thresh = 0, labels = NA, breaks = NA,
w.shift = 0, remove.empty = TRUE, main = NULL, key.header = "",
key.footer = "", key.position = "right", key = TRUE, auto.text = TRUE,
...)
{
conc.mat <- NULL
if (w.shift < 0 || w.shift > 6) {
warning("w.shift should be between 0 and 6")
}
weekday.abb <- substr(format(ISOdate(2000, 1, 2:8), "%A"),
1, 1)[((6:12) + w.shift)%%7 + 1]
extra.args <- list(...)
current.strip <- trellis.par.get("strip.background")
current.font <- trellis.par.get("fontsize")
on.exit(trellis.par.set(fontsize = current.font))
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)
}
if ("fontsize" %in% names(extra.args)) {
trellis.par.set(fontsize = list(text = extra.args$fontsize))
}
if (annotate %in% c("date", "value"))
vars <- c("date", pollutant)
if (annotate == "wd")
vars <- c("wd", "ws", "date", pollutant)
if (annotate == "ws")
vars <- c("wd", "ws", "date", pollutant)
if (!missing(year)) {
mydata <- selectByDate(mydata, year = year)
}
if (nrow(mydata) == 0)
stop("No data to plot - check year chosen")
mydata <- checkPrep(mydata, vars, "default", remove.calm = FALSE)
main <- quickText(main, auto.text)
def.theme <- list(strip.background = list(col = "#ffe5cc"),
strip.border = list(col = "black"), axis.line = list(col = "black"),
par.strip.text = list(cex = 1))
cal.theme <- list(strip.background = list(col = "grey90"),
strip.border = list(col = "transparent"), axis.line = list(col = "transparent"),
par.strip.text = list(cex = 0.8))
lattice.options(default.theme = cal.theme)
all.dates <- seq(as_date(floor_date(min(mydata$date), "month")),
as_date(ceiling_date(max(mydata$date), "month")) - 1,
by = "day")
prepare.grid <- function(mydata, pollutant) {
firstDay <- format(mydata$date[1], "%A")
lastDay <- as.numeric(format(mydata$date[length(mydata$date)],
"%d"))
pad.start <- (as.numeric(format(mydata$date[1], "%w")) -
w.shift)%%7 + 1
conc <- rev(mydata[[pollutant]])
theDates <- as.numeric(format(mydata$date, "%d"))
theDates <- rev(theDates)
daysAtEnd <- 42 - pad.start - nrow(mydata)
conc <- c(rep(NA, daysAtEnd), conc)
endDates <- mydata$date[nrow(mydata)] + (1:daysAtEnd)
endDates <- rev(as.numeric(format(endDates, "%d")))
theDates <- c(endDates, theDates)
beginDates <- -1 * (1:pad.start) + mydata$date[1]
beginDates <- as.numeric(format(beginDates, "%d"))
conc <- c(conc, rep(NA, pad.start))
if (pad.start != 0)
theDates <- c(theDates, beginDates)
dateColour <- c(rep("grey70", daysAtEnd), rep("black",
nrow(mydata)), rep("grey70", pad.start))
conc.mat <- matrix(conc, ncol = 7, byrow = TRUE)
date.mat <- matrix(theDates, ncol = 7, byrow = TRUE)
colour.mat <- matrix(dateColour, ncol = 7, byrow = TRUE)
conc.mat <- as.vector(apply(conc.mat, 1, rev))
date.mat <- as.vector(apply(date.mat, 1, rev))
colour.mat <- as.vector(apply(colour.mat, 1, rev))
grid <- data.frame(expand.grid(x = 1:7, y = 1:6))
results <- suppressWarnings(data.frame(x = grid$x, y = grid$y,
conc.mat, date.mat = date.mat, dateColour = colour.mat))
results
}
mydata <- timeAverage(mydata, "day", statistic = statistic,
data.thresh = data.thresh)
mydata$date <- as_date(mydata$date)
type <- "cuts"
mydata <- left_join(data.frame(date = all.dates), mydata,
by = "date")
mydata <- mutate(mydata, cuts = format(date, "%B-%Y"), cuts = ordered(cuts,
levels = unique(cuts)))
if (remove.empty) {
mydata <- group_by(mydata, cuts) %>% mutate(empty = all(is.na(UQS(syms(pollutant))))) %>%
filter(empty == FALSE)
}
baseData <- mydata
mydata <- group_by(mydata, UQS(syms(type))) %>% do(prepare.grid(.,
pollutant))
mydata$value <- mydata$conc.mat
strip.dat <- strip.fun(mydata, type, auto.text)
strip <- strip.dat[[1]]
category <- FALSE
if (!is.na(labels) && !is.na(breaks)) {
category <- TRUE
mydata <- transform(mydata, conc.mat = cut(conc.mat,
breaks = breaks, labels = labels))
}
if (annotate == "wd") {
baseData$wd <- baseData$wd * 2 * pi/360
wd <- group_by(baseData, UQS(syms(type))) %>% do(prepare.grid(.,
"wd"))
wd$value <- wd$conc.mat
}
if (annotate == "ws") {
baseData$wd <- baseData$wd * 2 * pi/360
ws <- group_by(baseData, UQS(syms(type))) %>% do(prepare.grid(.,
"ws"))
wd <- group_by(baseData, UQS(syms(type))) %>% do(prepare.grid(.,
"wd"))
ws$conc.mat <- ws$conc.mat/max(ws$conc.mat, na.rm = TRUE)
ws$value <- ws$conc.mat
wd$value <- wd$conc.mat
}
if (category) {
if (length(labels) + 1 != length(breaks))
stop("Need one more break than labels")
n <- length(levels(mydata$conc.mat))
col <- openColours(cols, n)
legend <- list(col = col, space = key.position, auto.text = auto.text,
labels = levels(mydata$conc.mat), footer = key.footer,
header = key.header, height = 0.8, width = 1.5,
fit = "scale", plot.style = "other")
col.scale <- breaks
legend <- makeOpenKeyLegend(key, legend, "windRose")
}
else {
nlev <- 200
if (missing(limits)) {
breaks <- pretty(mydata$value, n = nlev)
labs <- pretty(breaks, 7)
labs <- labs[labs >= min(breaks) & labs <= max(breaks)]
}
else {
breaks <- pretty(limits, n = nlev)
labs <- pretty(breaks, 7)
labs <- labs[labs >= min(breaks) & labs <= max(breaks)]
if (max(limits) < max(mydata$value, na.rm = TRUE)) {
id <- which(mydata$value > max(limits))
mydata$value[id] <- max(limits)
labs <- pretty(breaks, 7)
labs <- labs[labs >= min(breaks) & labs <= max(breaks)]
labs[length(labs)] <- paste(">", labs[length(labs)])
}
}
nlev2 <- length(breaks)
col <- openColours(cols, (nlev2 - 1))
col.scale <- breaks
legend <- list(col = col, at = col.scale, labels = list(labels = labs),
space = key.position, auto.text = auto.text, footer = key.footer,
header = key.header, height = 1, width = 1.5, fit = "all")
legend <- makeOpenKeyLegend(key, legend, "calendarPlot")
}
lv.args <- list(x = value ~ x * y | cuts, data = mydata,
par.settings = cal.theme, main = main, strip = strip,
par.strip.text = list(cex = 0.9), at = col.scale, col.regions = col,
as.table = TRUE, scales = list(y = list(draw = FALSE),
x = list(at = 1:7, labels = weekday.abb, tck = 0),
par.strip.text = list(cex = 0.8), alternating = 1,
relation = "free"), aspect = 6/7, between = list(x = 1),
colorkey = FALSE, legend = legend, panel = function(x,
y, subscripts, ...) {
panel.levelplot(x, y, subscripts, ...)
panel.abline(v = c(0.5:7.5), col = "grey90")
panel.abline(h = c(0.5:7.5), col = "grey90")
if (annotate == "date") {
ltext(x, y, labels = mydata$date.mat[subscripts],
cex = 0.6, col = as.character(mydata$dateColour[subscripts]))
}
if (annotate == "value") {
date.col <- as.character(mydata$dateColour[subscripts])
ids <- which(date.col == "black")
date.col[ids] <- "transparent"
ltext(x, y, labels = mydata$date.mat[subscripts],
cex = 0.6, col = date.col)
concs <- mydata$value[subscripts]
ids <- seq_along(concs)
the.cols <- rep(col.lim[1], length(ids))
the.font <- rep(font.lim[1], length(ids))
the.cex <- rep(cex.lim[1], length(ids))
if (!is.null(lim)) {
ids <- which(concs >= lim)
the.cols[ids] <- col.lim[2]
the.font[ids] <- font.lim[2]
the.cex[ids] <- cex.lim[2]
}
the.labs <- round(concs, digits = digits)
id <- which(is.na(the.labs))
if (length(id) > 0) {
the.labs <- as.character(the.labs)
the.labs[id] <- ""
}
ltext(x, y, labels = the.labs, cex = the.cex,
font = the.font, col = the.cols)
}
if (annotate == "wd") {
larrows(x + 0.5 * sin(wd$value[subscripts]),
y + 0.5 * cos(wd$value[subscripts]), x + -0.5 *
sin(wd$value[subscripts]), y + -0.5 * cos(wd$value[subscripts]),
angle = 20, length = 0.07, lwd = 0.5, col = col.arrow)
}
if (annotate == "ws") {
larrows(x + (0.5 * sin(wd$value[subscripts]) *
ws$value[subscripts]), y + (0.5 * cos(wd$value[subscripts]) *
ws$value[subscripts]), x + (-0.5 * sin(wd$value[subscripts]) *
ws$value[subscripts]), y + (-0.5 * cos(wd$value[subscripts]) *
ws$value[subscripts]), angle = 20, length = 0.07,
lwd = 0.5, col = col.arrow)
}
})
lv.args <- listUpdate(lv.args, extra.args)
print(do.call(levelplot, lv.args))
lattice.options(default.theme = def.theme)
plt <- trellis.last.object()
newdata <- mydata
output <- list(plot = plt, data = newdata, call = match.call())
class(output) <- "openair"
invisible(output)
}
大佬 我的代码是这个 求帮看
扫码加好友，拉您进群
全部版块
我的主页
收藏
