R语言画日历热图calendarPlot显示星期问题

是 否 +2 论坛币

k人 参与回答

经管之家送您一份

应届毕业生专属福利!

求职就业群

赵安豆老师微信：zhaoandou666

经管之家联合CDA

送您一个全额奖学金名额~ !

立即领取

感谢您参与论坛问题回答

经管之家送您两个论坛币！

+2 论坛币

    用R语言画日历图的时候 下面的星期显示成这个样子 想问问各位大神表头和星期这是标签要怎么改呀 希望能改成下面图的样子。

扫码加我 拉你入群

请注明：姓名-公司-职位

以便审核进群资格，未注明则拒绝

分享0 收藏1 回帖

关键词：Calendar Alen plot ale ARP

求助呀求助呀 大佬们理理我

Mashiro1994 发表于 2019-8-5 11:19
用R语言画日历图的时候 下面的星期显示成这个样子 想问问各位大神表头和星期这是标签要怎么改呀 希望 ...

你的代码呢？

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

大佬 我的代码是这个 求帮看

Mashiro1994 发表于 2019-8-13 12:01
function (mydata, pollutant = "nox", year = 2003, month = 1:12,
        type = "default", annotate = "d ...

你好，请问你的问题解决了吗，我正在用openair画日历图，出现同样的问题，不知道怎么修改星期几。。。如果看到消息的话可以帮忙回复一下吗，非常感谢！

参考之前那个帖子:(https://bbs.pinggu.org/thread-6225730-2-1.html)一开始我也是直接添加

1. weekdays.abb <- c("日","一","二","三","四","五","六")

复制代码

但是老是报错,不知道如何解决:

1. fix(my_calendarPlot)
   
2. Error in parse(file) : invalid multibyte character in parser at line 14

复制代码

之后把那句的(1,1),修改为(3,3)

1. weekday.abb <- substr(format(ISOdate(2000, 1, 2:8), "%A"),
   
2.                         3, 3)[((6:12) + w.shift)%%7 + 1]

复制代码

就可以了.其余的就是照着那个帖子,运行不了找的函数位置加上:

1. openair:::

复制代码

就可以