Related
I am looking to have each frame of a scatter plot be filtered by another vector with a certain bin width and have it it roll through those. For example I can do this by:
library(ggplot2)
library(gganimate)
#example data
iris <- datasets::iris
#plot x and y
g <- ggplot(iris) + geom_point(aes(x = Petal.Width,y = Petal.Length))
#filter x and y by a third value with a bin width of 2 steping through by 0.5
g + transition_filter(transition_length = 1,
filter_length = 1,
4 < Sepal.Length & Sepal.Length < 6,
4.5 < Sepal.Length & Sepal.Length < 6.5,
5 < Sepal.Length & Sepal.Length < 7,
5.5 < Sepal.Length & Sepal.Length < 7.5,
6 < Sepal.Length & Sepal.Length < 8)
However - writing out each filter condition is tedious, and I would like to filter a different dataset with a ~20 binwidth steping through by 1 over a 300 point range so writing 100+ filters is not practical.
Is there another way to do this?
A while ago I wanted this exact function but didn't actually see anything in gganimate to do it, so I wrote something that would get the job done. Below is what I came up with, so I ended up rebuilding gganimate with this function included to avoid using :::.
I wrote this a while ago so I don't recall the exact intention of each argument at the moment of writing it (ALWAYS REMEMBER TO DOCUMENT YOUR CODE).
Here is what I recall
span : expression that can be evaluated within the data layers
size : how much data to be shown at once
enter_length/exit_length : Don't exactly recall how it works in relation to each other or size/span
range : a subset range
retain_data_order : logical - don't remember why this is here (sorry!)
library(gganimate)
#> Loading required package: ggplot2
library(rlang)
library(tweenr)
library(stringi)
get_row_event <- gganimate:::get_row_event
is_placeholder <- gganimate:::is_placeholder
recast_event_times <- gganimate:::recast_event_times
recast_times <- gganimate:::recast_times
TransitionSpan <- ggplot2::ggproto('TransitionSpan',
TransitionEvents,
finish_data = function (self, data, params)
{
lapply(data, function(d) {
split_panel <- stri_match(d$group, regex = "^(.+)<(.*)>(.*)$")
if (is.na(split_panel[1]))
return(list(d))
d$group <- match(d$group, unique(d$group))
empty_d <- d[0, , drop = FALSE]
d <- split(d, as.integer(split_panel[, 3]))
frames <- rep(list(empty_d), params$nframes)
frames[as.integer(names(d))] <- d
frames
})
},
setup_params = function(self, data, params) {
# browser()
params$start <- get_row_event(data, params$span_quo, "start")
time_class <- if (is_placeholder(params$start))
NULL
else params$start$class
end_quo <- expr(!!params$span_quo + diff(range(!!params$span_quo))*!!params$size_quo)
params$end <- get_row_event(data, end_quo, "end",
time_class)
params$enter_length <- get_row_event(data, params$enter_length_quo,
"enter_length", time_class)
params$exit_length <- get_row_event(data, params$exit_length_quo,
"exit_length", time_class)
params$require_stat <- is_placeholder(params$start) || is_placeholder(params$end) ||
is_placeholder(params$enter_length) || is_placeholder(params$exit_length)
static = lengths(params$start$values) == 0
params$row_id <- Map(function(st, end, en, ex, s) if (s)
character(0)
else paste(st, end, en, ex, sep = "_"), st = params$start$values,
end = params$end$values, en = params$enter_length$values,
ex = params$exit_length$values, s = static)
params
},
setup_params2 = function(self, data, params, row_vars) {
late_start <- FALSE
if (is_placeholder(params$start)) {
params$start <- get_row_event(data, params$start_quo, 'start', after = TRUE)
late_start <- TRUE
} else {
params$start$values <- lapply(row_vars$start, as.numeric)
}
size <- expr(!!params$size_quo)
time_class <- params$start$class
if (is_placeholder(params$end)) {
params$end <- get_row_event(data, params$end_quo, 'end', time_class, after = TRUE)
} else {
params$end$values <- lapply(row_vars$end, as.numeric)
}
if (is_placeholder(params$enter_length)) {
params$enter_length <- get_row_event(data, params$enter_length_quo, 'enter_length', time_class, after = TRUE)
} else {
params$enter_length$values <- lapply(row_vars$enter_length, as.numeric)
}
if (is_placeholder(params$exit_length)) {
params$exit_length <- get_row_event(data, params$exit_length_quo, 'exit_length', time_class, after = TRUE)
} else {
params$exit_length$values <- lapply(row_vars$exit_length, as.numeric)
}
times <- recast_event_times(params$start, params$end, params$enter_length, params$exit_length)
params$span_size <- diff(times$start$range)*eval_tidy(size)
range <- if (is.null(params$range)) {
low <- min(unlist(Map(function(start, enter) {
start - (if (length(enter) == 0) 0 else enter)
}, start = times$start$values, enter = times$enter_length$values)))
high <- max(unlist(Map(function(start, end, exit) {
(if (length(end) == 0) start else end) + (if (length(exit) == 0) 0 else exit)
}, start = times$start$values, end = times$end$values, exit = times$exit_length$values)))
range <- c(low, high)
} else {
if (!inherits(params$range, time_class)) {
stop('range must be given in the same class as time', call. = FALSE)
}
as.numeric(params$range)
}
full_length <- diff(range)
frame_time <- recast_times(
seq(range[1], range[2], length.out = params$nframes),
time_class
)
frame_length <- full_length / params$nframes
rep_frame <- round(params$span_size/frame_length)
lowerl <- c(rep(frame_time[1],rep_frame), frame_time[2:(params$nframes-rep_frame+1)])
upperl <- c(frame_time[1:(params$nframes-rep_frame)], rep(frame_time[params$nframes-rep_frame+1], rep_frame))
start <- lapply(times$start$values, function(x) {
round((params$nframes - 1) * (x - range[1])/full_length) + 1
})
end <- lapply(times$end$values, function(x) {
if (length(x) == 0) return(numeric())
round((params$nframes - 1) * (x - range[1])/full_length) + 1
})
enter_length <- lapply(times$enter_length$values, function(x) {
if (length(x) == 0) return(numeric())
round(x / frame_length)
})
exit_length <- lapply(times$exit_length$values, function(x) {
if (length(x) == 0) return(numeric())
round(x / frame_length)
})
params$range <- range
params$frame_time <- frame_time
static = lengths(start) == 0
params$row_id <- Map(function(st, end, en, ex, s) if (s) character(0) else paste(st, end, en, ex, sep = '_'),
st = start, end = end, en = enter_length, ex = exit_length, s = static)
params$lowerl <- lowerl
params$upperl <- upperl
params$frame_span <- upperl - lowerl
params$frame_info <- data.frame(
frame_time = frame_time,
lowerl = lowerl,
upperl = upperl,
frame_span = upperl - lowerl
)
params$nframes <- nrow(params$frame_info)
params
},
expand_panel = function(self, data, type, id, match, ease, enter, exit, params, layer_index) {
#browser()
row_vars <- self$get_row_vars(data)
if (is.null(row_vars))
return(data)
data$group <- paste0(row_vars$before, row_vars$after)
start <- as.numeric(row_vars$start)
end <- as.numeric(row_vars$end)
if (is.na(end[1]))
end <- NULL
enter_length <- as.numeric(row_vars$enter_length)
if (is.na(enter_length[1]))
enter_length <- NULL
exit_length <- as.numeric(row_vars$exit_length)
if (is.na(exit_length[1]))
exit_length <- NULL
data$.start <- start
all_frames <- tween_events(data, c(ease,"linear"),
params$nframes, !!start, !!end, c(1, params$nframes),
enter, exit, !!enter_length, !!exit_length)
if(params$retain_data_order){
all_frames <- all_frames[order(as.numeric(all_frames$.id)),]
} else {
all_frames <- all_frames[order(all_frames$.start, as.numeric(all_frames$.id)),]
}
all_frames$group <- paste0(all_frames$group, '<', all_frames$.frame, '>')
all_frames$.frame <- NULL
all_frames$.start <- NULL
all_frames
})
transition_span <- function(span, size = 0.5, enter_length = NULL, exit_length = NULL, range = NULL, retain_data_order = T){
span_quo <- enquo(span)
size_quo <- enquo(size)
enter_length_quo <- enquo(enter_length)
exit_length_quo <- enquo(exit_length)
gganimate:::require_quo(span_quo, "span")
ggproto(NULL, TransitionSpan,
params = list(span_quo = span_quo,
size_quo = size_quo, range = range, enter_length_quo = enter_length_quo,
exit_length_quo = exit_length_quo,
retain_data_order = retain_data_order))
}
g <- ggplot(iris) +
geom_point(aes(x = Petal.Width,y = Petal.Length, color = Sepal.Length)) +
viridis::scale_color_viridis()
a <- g + transition_span(Sepal.Length, .1, 1, 1)
animate(a, renderer = gganimate::gifski_renderer())
Created on 2021-08-11 by the reprex package (v2.0.0)
I have adapted the codes below which I referred from https://statsandr.com/blog/how-to-do-a-t-test-or-anova-for-many-variables-at-once-in-r-and-communicate-the-results-in-a-better-way/#to-go-even-further into my dataset:
Day<-c(1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2)
Group<-c("A","A","A","B","B","B","C","C","C","A","A","A","A","B","B","B","C","C","C")
Rain<-c(4,4,6,5,3,4,5,5,3,6,6,6,5,3,3,3,2,5,2)
UV<-c(6,6,7,8,5,6,5,6,6,6,7,7,8,8,5,6,8,5,7)
dat<-data.frame(Day,Group,Rain,UV)
x <- which(names(dat) == "Group")
y <- which(names(dat) == "Rain"
| names(dat) == "UV")
method1 <- "kruskal.test"
method2 <- "wilcox.test"
my_comparisons <- list(c("A", "B"), c("A", "C"), c("B", "C")) # comparisons for post-hoc test
library(ggpubr)
for (i in y) {
for (j in x) {
p <- ggboxplot(dat,
x = colnames(dat[j]), y = colnames(dat[i]),
color = colnames(dat[j]),
legend = "none",
palette = "npg",
add = "jitter"
)
print(
p + stat_compare_means(aes(label = paste0(..method.., ", p-value = ", ..p.format..)),
method = method1, label.y = max(dat[, i], na.rm = TRUE)
)
+ stat_compare_means(comparisons = my_comparisons, method = method2, label = "p.format")
)
}
}
How do I further repeat this function through different "Day"? Thanks.
I think you want to see the results for each day, right? You can add a third loop like this:
for (h in unique(dat$Day)) {
for (i in y) {
for (j in x) {
dat_tmp <- dat[dat$Day == h,] # create a subset of the data for each day
p <- ggboxplot(dat_tmp,
x = colnames(dat_tmp[j]), y = colnames(dat_tmp[i]),
color = colnames(dat_tmp[j]),
legend = "none",
palette = "npg",
add = "jitter"
)
print(
p + stat_compare_means(aes(label = paste0(..method.., ", p-value = ", ..p.format..)),
method = method1, label.y = max(dat_tmp[, i], na.rm = TRUE)
)
+ stat_compare_means(comparisons = my_comparisons, method = method2, label = "p.format")
)
}
}
}
I added a third loop to your code and created dat_tmp inside the loop, which becomes the dataset that you use for the analyses of each day.
Im building a shinyapp from a log regression using the DynNom::DNbuilder R package. I obtained the ui.R, server.R and global.R code and the app works. However, I'm trying to change the format of the sliders and the labels but I haven't been able to do so.
I'd appreciate if someone could shed some light here . Thanks!
Here's my model and the labels i would like the app to show:
data <- data.frame(
x = c(0,1,0),
y = c(3,6,2),
z = c(1.3, 2.8, 3.1),
w = c(1,0,0)
)
model <- lrm(x ~ y + z + w, data = data)
modellabels <- c("ylabel", "zlabel", "wlabel")
Here's the DNbuilder code:
model <- lrm(x ~ y + z + w, data =data
DNbuilder(model, data = data, clevel = 0.95, m.summary = c("raw"), covariate = c("numeric"))
Here's what I got after running DNbuilder:
**ui.R**
ui = bootstrapPage(fluidPage(
titlePanel('app'),
sidebarLayout(sidebarPanel(uiOutput('manySliders'),
uiOutput('setlimits'),
actionButton('add', 'Predict'),
br(), br(),
helpText('Press Quit to exit the application'),
actionButton('quit', 'Quit')
),
mainPanel(tabsetPanel(id = 'tabs',
tabPanel('Graphical Summary', plotlyOutput('plot')),
tabPanel('Numerical Summary', verbatimTextOutput('data.pred')),
tabPanel('Model Summary', verbatimTextOutput('summary'))
)
)
)))
----------
**server.R**
server = function(input, output){
observe({if (input$quit == 1)
stopApp()})
limits <- reactive({ if (input$limits) { limits <- c(input$lxlim, input$uxlim) } else {
limits <- limits0 } })
output$manySliders <- renderUI({
slide.bars <- list()
for (j in 1:length(preds)){
if (terms[j+1] == "factor"){
slide.bars[[j]] <- list(selectInput(paste("pred", j, sep = ""), names(preds)[j], preds[[j]]$v.levels, multiple = FALSE))
}
if (terms[j+1] == "numeric"){
if (covariate == "slider") {
slide.bars[[j]] <- list(sliderInput(paste("pred", j, sep = ""), names(preds)[j],
min = preds[[j]]$v.min, max = preds[[j]]$v.max, value = preds[[j]]$v.mean))
}
if (covariate == "numeric") {
slide.bars[[j]] <- list(numericInput(paste("pred", j, sep = ""), names(preds)[j], value = zapsmall(preds[[j]]$v.mean, digits = 4)))
}}}
do.call(tagList, slide.bars)
})
output$setlimits <- renderUI({
if (is.null(DNlimits)){
setlim <- list(checkboxInput("limits", "Set x-axis ranges"),
conditionalPanel(condition = "input.limits == true",
numericInput("uxlim", "x-axis upper", zapsmall(limits0[2], digits = 2)),
numericInput("lxlim", "x-axis lower", zapsmall(limits0[1], digits = 2))))
} else{ setlim <- NULL }
setlim
})
a <- 0
new.d <- reactive({
input$add
input.v <- vector("list", length(preds))
for (i in 1:length(preds)) {
input.v[[i]] <- isolate({
input[[paste("pred", i, sep = "")]]
})
names(input.v)[i] <- names(preds)[i]
}
out <- data.frame(lapply(input.v, cbind))
if (a == 0) {
input.data <<- rbind(input.data, out)
}
if (a > 0) {
if (!isTRUE(compare(old.d, out))) {
input.data <<- rbind(input.data, out)
}}
a <<- a + 1
out
})
p1 <- NULL
old.d <- NULL
data2 <- reactive({
if (input$add == 0)
return(NULL)
if (input$add > 0) {
if (!isTRUE(compare(old.d, new.d()))) {
isolate({
mpred <- getpred.DN(model, new.d(), set.rms=T)$pred
se.pred <- getpred.DN(model, new.d(), set.rms=T)$SEpred
if (is.na(se.pred)) {
lwb <- "No standard errors"
upb <- "by 'lrm'"
pred <- mlinkF(mpred)
d.p <- data.frame(Prediction = zapsmall(pred, digits = 3),
Lower.bound = lwb, Upper.bound = upb)
} else {
lwb <- sort(mlinkF(mpred + cbind(1, -1) * (qnorm(1 - (1 - clevel)/2) * se.pred)))[1]
upb <- sort(mlinkF(mpred + cbind(1, -1) * (qnorm(1 - (1 - clevel)/2) * se.pred)))[2]
pred <- mlinkF(mpred)
d.p <- data.frame(Prediction = zapsmall(pred, digits = 3),
Lower.bound = zapsmall(lwb, digits = 3),
Upper.bound = zapsmall(upb, digits = 3))
}
old.d <<- new.d()
data.p <- cbind(d.p, counter = 1, count=0)
p1 <<- rbind(p1, data.p)
p1$counter <- seq(1, dim(p1)[1])
p1$count <- 0:(dim(p1)[1]-1) %% 11 + 1
p1
})
} else {
p1$count <- seq(1, dim(p1)[1])
}}
rownames(p1) <- c()
p1
})
output$plot <- renderPlotly({
if (input$add == 0)
return(NULL)
if (is.null(new.d()))
return(NULL)
coll=c("#0E0000", "#0066CC", "#E41A1C", "#54A552", "#FF8000", "#BA55D3",
"#006400", "#994C00", "#F781BF", "#00BFFF", "#A9A9A9")
lim <- limits()
yli <- c(0 - 0.5, 10 + 0.5)
dat2 <- data2()
if (dim(data2())[1] > 11){
input.data = input.data[-c(1:(dim(input.data)[1]-11)),]
dat2 <- data2()[-c(1:(dim(data2())[1]-11)),]
yli <- c(dim(data2())[1] - 11.5, dim(data2())[1] - 0.5)
}
in.d <- input.data
xx <- matrix(paste(names(in.d), ": ", t(in.d), sep = ""), ncol = dim(in.d)[1])
Covariates <- apply(xx, 2, paste, collapse = "<br />")
p <- ggplot(data = dat2, aes(x = Prediction, y = counter - 1, text = Covariates,
label = Prediction, label2 = Lower.bound, label3=Upper.bound)) +
geom_point(size = 2, colour = coll[dat2$count], shape = 15) +
ylim(yli[1], yli[2]) + coord_cartesian(xlim = lim) +
labs(title = "95% Confidence Interval for Response",
x = "Probability", y = "") + theme_bw() +
theme(axis.text.y = element_blank(), text = element_text(face = "bold", size = 10))
if (is.numeric(dat2$Upper.bound)){
p <- p + geom_errorbarh(xmax = dat2$Upper.bound, xmin = dat2$Lower.bound,
size = 1.45, height = 0.4, colour = coll[dat2$count])
} else{
message("Confidence interval is not available as there is no standard errors available by 'lrm' ")
}
gp <- ggplotly(p, tooltip = c("text", "label", "label2", "label3"))
gp$elementId <- NULL
gp
})
output$data.pred <- renderPrint({
if (input$add > 0) {
if (nrow(data2()) > 0) {
if (dim(input.data)[2] == 1) {
in.d <- data.frame(input.data)
names(in.d) <- names(terms)[2]
data.p <- cbind(in.d, data2()[1:3])
}
if (dim(input.data)[2] > 1) {
data.p <- cbind(input.data, data2()[1:3])
}}
stargazer(data.p, summary = FALSE, type = "text")
}
})
output$summary <- renderPrint({
print(model)
})
}
----------
**global.R**
library(ggplot2)
library(shiny)
library(plotly)
library(stargazer)
library(compare)
library(prediction)
library(rms)
load('data.RData')
source('functions.R')
t.dist <- datadist(data)
options(datadist = 't.dist')
m.summary <- 'raw'
covariate <- 'numeric'
clevel <- 0.95
I am not quite sure which type of shiny widget (or labels) you mean, but I have some comments.
Firstly, you need to make sure defining your variables' class correctly (e.g. as factors, numeric, ...), for example, by adding the following code before fitting your model:
> data$y <- as.factor(data$y)
This is especially important for factors so it gets factor levels. For numerical variables, you can get a shiny slider (by default) or a numeric input (using covariate = c("numeric")).
The labels for widgets are the same as the variable names. So the easiest way to adjust them is by changing the variable names as you like before fitting your model:
> names(data)
[1] "x" "y" "z"
> names(data)[2] <- 'ylabel'
> names(data)
[1] "x" "ylabel" "z"
> model <- lrm(x ~ ylabel + z, data = data)
Alternatively, the labels can be changed by adjusting the 'preds' object in the 'data.RData'. For example, you can use the following code to change labels:
> names(preds)
[1] "y" "z"
> names(preds)[1] <- 'labelled y'
> names(preds)
[1] "labelled y" "z"
> save.image(file = "data.RData")
I hope I am missing something painfully obvious here.
I wish to update (e.g., fix title, labs, etc.) on a ggplot object produced from gratia::draw(). Not really sure why I am unable to update the object.
Is there a simple solution?
# devtools::install_github('gavinsimpson/gratia')
library('mgcv')
library('gratia')
dat <- gamSim(1, n = 400, dist = "normal", scale = 2, verbose = FALSE)
mod <- gam(y ~ s(x0), data = dat, method = "REML")
draw(mod)
p = draw(mod)
# P is a ggobject.
class(p)
#> [1] "gg" "ggplot"
So, why can't I update p?
p + ggtitle("My title")
Created on 2019-02-26 by the reprex package (v0.2.1)
The object returned by draw.gam is the output of cowplot::plot_grid (not a pure ggplot2 graphical object).
I made a small change into draw.gam function of gratia. .
Now the p object can be manipulated:
# The modified draw.gam function
mydraw.gam <- function (object, parametric = TRUE, select = NULL, scales = c("free",
"fixed"), align = "hv", axis = "lrtb", n = 100, unconditional = FALSE,
overall_uncertainty = TRUE, dist = 0.1, ...)
{
scales <- match.arg(scales)
S <- smooths(object)
select <- gratia:::check_user_select_smooths(smooths = S, select = select)
d <- gratia:::smooth_dim(object)
take <- d <= 2L
select <- select[take]
S <- S[take]
d <- d[take]
is_re <- vapply(object[["smooth"]], gratia:::is_re_smooth, logical(1L))
is_by <- vapply(object[["smooth"]], gratia:::is_by_smooth, logical(1L))
if (any(is_by)) {
S <- vapply(strsplit(S, ":"), `[[`, character(1L), 1L)
}
npara <- 0
nsmooth <- length(S)
if (isTRUE(parametric)) {
terms <- parametric_terms(object)
npara <- length(terms)
p <- vector("list", length = npara)
}
g <- l <- vector("list", length = nsmooth)
for (i in unique(S)) {
eS <- evaluate_smooth(object, smooth = i, n = n, unconditional = unconditional,
overall_uncertainty = overall_uncertainty, dist = dist)
l[S == i] <- split(eS, eS[["smooth"]])
}
l <- l[select]
d <- d[select]
g <- g[select]
if (length(g) == 0L) {
message("Unable to draw any of the model terms.")
return(invisible(g))
}
for (i in seq_along(l)) {
g[[i]] <- draw(l[[i]])
}
if (isTRUE(parametric)) {
for (i in seq_along(terms)) {
p[[i]] <- evaluate_parametric_term(object, term = terms[i])
g[[i + length(g)]] <- draw(p[[i]])
}
}
if (isTRUE(identical(scales, "fixed"))) {
wrapper <- function(x) {
range(x[["est"]] + (2 * x[["se"]]), x[["est"]] -
(2 * x[["se"]]))
}
ylims <- range(unlist(lapply(l, wrapper)))
if (isTRUE(parametric)) {
ylims <- range(ylims, unlist(lapply(p, function(x) range(x[["upper"]],
x[["lower"]]))))
}
gg <- seq_along(g)[c(d == 1L, rep(TRUE, npara))]
for (i in gg) {
g[[i]] <- g[[i]] + lims(y = ylims)
}
}
g
}
# Example no. 1
dat <- gamSim(1, n = 400, dist = "normal", scale = 2, verbose = FALSE)
mod <- gam(y ~ s(x0), data = dat, method = "REML")
p <- mydraw.gam(mod)
p[[1]] + ggtitle("My title")
# Example no. 2
mod <- gam(y ~ s(x0) + x1, data = dat, method = "REML")
p <- mydraw.gam(mod)
# Plot graphs separately
p[[1]] + ggtitle("My title")
p[[2]] + ggtitle("My title")
# Arrange the two plots on the same figure
cowplot::plot_grid(plotlist = p)
Reposts from Gavin Simpson and Hao Ye, respectively:
I think the only way to change the title(s) on the individual plots of smooths would be to use draw(evaluate_smooth(model, "smooth"), title = "My title") individually at the moment.
You might be able to hack a title in a different way:
draw(mod) +
ggplot2::coord_cartesian(clip = "off") +
ggplot2::theme(plot.margin = ggplot2::unit(c(0.05, 0, 0, 0), "npc")) +
ggplot2::annotate("text", x = 0.5, y = 1, vjust = 0, label = "TITLE", size = 6)
I have created a multipanel Taylor plot using openair package. I want to change the font size of 'correlation' and 'observed' and make it sentence case. I have used the following code:
TaylorDiagram(data, obs = "Observed", mod = "Predicted", group = "Method", type = "Station")
The task is now achieved by changing the source code of TaylorDiagram from openair package using the following code
library(lattice)
library(dplyr)
TaylorDiagram1 <- function(mydata, obs = "obs", mod = "mod", group = NULL, type = "default",
normalise = FALSE, cols = "brewer1",
rms.col = "darkgoldenrod", cor.col = "black", arrow.lwd = 3,
annotate = "centred\nRMS error",
key = TRUE, key.title = group, key.columns = 1,
key.pos = "right", strip = TRUE, auto.text = TRUE, ...) {
## get rid of R check annoyances
sd.mod <- R <- NULL
## greyscale handling
## set graphics
current.strip <- trellis.par.get("strip.background")
current.font <- trellis.par.get("fontsize")
## reset graphic parameters
on.exit(trellis.par.set(
fontsize = current.font
))
if (length(cols) == 1 && cols == "greyscale") {
trellis.par.set(list(strip.background = list(col = "white")))
## other local colours
method.col <- "greyscale"
} else {
method.col <- "default"
}
## extra.args setup
extra.args <- list(...)
## label controls (some local xlab, ylab management in code)
extra.args$xlab <- if ("xlab" %in% names(extra.args)) {
quickText(extra.args$xlab, auto.text)
} else {
NULL
}
extra.args$ylab <- if ("ylab" %in% names(extra.args)) {
quickText(extra.args$ylab, auto.text)
} else {
NULL
}
extra.args$main <- if ("main" %in% names(extra.args)) {
quickText(extra.args$main, auto.text)
} else {
quickText("", auto.text)
}
if ("fontsize" %in% names(extra.args)) {
trellis.par.set(fontsize = list(text = extra.args$fontsize))
}
if (!"layout" %in% names(extra.args)) {
extra.args$layout <- NULL
}
if (!"pch" %in% names(extra.args)) {
extra.args$pch <- 20
}
if (!"cex" %in% names(extra.args)) {
extra.args$cex <- 2
}
## #######################################################################################
## check to see if two data sets are present
combine <- FALSE
if (length(mod) == 2) combine <- TRUE
if (any(type %in% dateTypes)) {
vars <- c("date", obs, mod)
} else {
vars <- c(obs, mod)
}
## assume two groups do not exist
twoGrp <- FALSE
if (!missing(group)) if (any(group %in% type)) stop("Can't have 'group' also in 'type'.")
mydata <- cutData(mydata, type, ...)
if (missing(group)) {
if ((!"group" %in% type) & (!"group" %in% c(obs, mod))) {
mydata$group <- factor("group")
group <- "group"
npol <- 1
}
## don't overwrite a
} else { ## means that group is there
mydata <- cutData(mydata, group, ...)
}
## if group is present, need to add that list of variables unless it is
## a pre-defined date-based one
if (!missing(group)) {
npol <- length(unique((mydata[[group[1]]])))
## if group is of length 2
if (length(group) == 2L) {
twoGrp <- TRUE
grp1 <- group[1]
grp2 <- group[2]
if (missing(key.title)) key.title <- grp1
vars <- c(vars, grp1, grp2)
mydata$newgrp <- paste(mydata[[group[1]]], mydata[[group[2]]], sep = "-")
group <- "newgrp"
}
if (group %in% dateTypes | any(type %in% dateTypes)) {
vars <- unique(c(vars, "date", group))
} else {
vars <- unique(c(vars, group))
}
}
## data checks, for base and new data if necessary
mydata <- checkPrep(mydata, vars, type)
# check mod and obs are numbers
mydata <- checkNum(mydata, vars = c(obs, mod))
## remove missing data
mydata <- na.omit(mydata)
legend <- NULL
## function to calculate stats for TD
calcStats <- function(mydata, obs = obs, mod = mod) {
R <- cor(mydata[[obs]], mydata[[mod]], use = "pairwise")
sd.obs <- sd(mydata[[obs]])
sd.mod <- sd(mydata[[mod]])
if (normalise) {
sd.mod <- sd.mod / sd.obs
sd.obs <- 1
}
res <- data.frame(R, sd.obs, sd.mod)
res
}
vars <- c(group, type)
results <- group_by(mydata, UQS(syms(vars))) %>%
do(calcStats(., obs = obs, mod = mod[1]))
results.new <- NULL
if (combine) {
results.new <- group_by(mydata, UQS(syms(vars))) %>%
do(calcStats(., obs = obs, mod = mod[2]))
}
## if no group to plot, then add a dummy one to make xyplot work
if (is.null(group)) {
results$MyGroupVar <- factor("MyGroupVar")
group <- "MyGroupVar"
}
## set up colours
myColors <- openColours(cols, npol)
pch.orig <- extra.args$pch
## combined colours if two groups
if (twoGrp) {
myColors <- rep(
openColours(cols, length(unique(mydata[[grp1]]))),
each = length(unique(mydata[[grp2]]))
)
extra.args$pch <- rep(extra.args$pch, each = length(unique(mydata[[grp2]])))
}
## basic function for lattice call + defaults
temp <- paste(type, collapse = "+")
myform <- formula(paste("R ~ sd.mod", "|", temp, sep = ""))
scales <- list(x = list(rot = 0), y = list(rot = 0))
pol.name <- sapply(levels(mydata[, group]), function(x) quickText(x, auto.text))
if (key & npol > 1 & !combine) {
thecols <- unique(myColors)
if (twoGrp) {
pol.name <- levels(factor(mydata[[grp1]]))
}
key <- list(
points = list(col = thecols), pch = pch.orig,
cex = extra.args$cex, text = list(lab = pol.name, cex = 0.8),
space = key.pos, columns = key.columns,
title = quickText(key.title, auto.text),
cex.title = 0.8, lines.title = 3
)
} else if (key & npol > 1 & combine) {
key <- list(
lines = list(col = myColors[1:npol]), lwd = arrow.lwd,
text = list(lab = pol.name, cex = 0.8), space = key.pos,
columns = key.columns,
title = quickText(key.title, auto.text),
cex.title = 0.8, lines.title = 3
)
} else {
key <- NULL
}
## special wd layout
if (length(type) == 1 & type[1] == "wd" & is.null(extra.args$layout)) {
## re-order to make sensible layout
wds <- c("NW", "N", "NE", "W", "E", "SW", "S", "SE")
mydata$wd <- ordered(mydata$wd, levels = wds)
## see if wd is actually there or not
wd.ok <- sapply(wds, function(x) {
if (x %in% unique(mydata$wd)) FALSE else TRUE
})
skip <- c(wd.ok[1:4], TRUE, wd.ok[5:8])
mydata$wd <- factor(mydata$wd) ## remove empty factor levels
extra.args$layout <- c(3, 3)
if (!"skip" %in% names(extra.args)) {
extra.args$skip <- skip
}
}
if (!"skip" %in% names(extra.args)) {
extra.args$skip <- FALSE
}
## proper names of labelling ####################################################
stripName <- sapply(levels(mydata[, type[1]]), function(x) quickText(x, auto.text))
if (strip) strip <- strip.custom(factor.levels = stripName)
if (length(type) == 1) {
strip.left <- FALSE
} else { ## two conditioning variables
stripName <- sapply(levels(mydata[, type[2]]), function(x) quickText(x, auto.text))
strip.left <- strip.custom(factor.levels = stripName)
}
## #############################################################################
## no strip needed for single panel
if (length(type) == 1 & type[1] == "default") strip <- FALSE
## not sure how to evaluate "group" in xyplot, so change to a fixed name
id <- which(names(results) == group)
names(results)[id] <- "MyGroupVar"
maxsd <- 1.2 * max(results$sd.obs, results$sd.mod)
# xlim, ylim handling
if (!"ylim" %in% names(extra.args)) {
extra.args$ylim <- 1.12 * c(0, maxsd)
}
if (!"xlim" %in% names(extra.args)) {
extra.args$xlim <- 1.12 * c(0, maxsd)
}
## xlab, ylab local management
if (is.null(extra.args$ylab)) {
extra.args$ylab <- if (normalise) "standard deviation (normalised)" else "Standard deviation"
}
if (is.null(extra.args$xlab)) {
extra.args$xlab <- extra.args$ylab
}
## plot
xyplot.args <- list(
x = myform, data = results, groups = results$MyGroupVar,
aspect = 1,
type = "n",
as.table = TRUE,
scales = scales,
key = key,
par.strip.text = list(cex = 0.8),
strip = strip,
strip.left = strip.left,
panel = function(x, y, ...) {
## annotate each panel but don't need to do this for each grouping value
panel.taylor.setup(
x, y,
results = results, maxsd = maxsd,
cor.col = cor.col, rms.col = rms.col,
annotate = annotate, ...
)
## plot data in each panel
panel.superpose(
x, y,
panel.groups = panel.taylor, ...,
results = results, results.new = results.new,
combine = combine, myColors = myColors,
arrow.lwd = arrow.lwd
)
}
)
## reset for extra.args
xyplot.args <- listUpdate(xyplot.args, extra.args)
## plot
plt <- do.call(xyplot, xyplot.args)
if (length(type) == 1) plot(plt) else plot(useOuterStrips(plt, strip = strip, strip.left = strip.left))
newdata <- results
output <- list(plot = plt, data = newdata, call = match.call())
class(output) <- "openair"
invisible(output)
}
panel.taylor.setup <- function(x, y, subscripts, results, maxsd, cor.col, rms.col,
col.symbol, annotate, group.number, type, ...) {
## note, this assumes for each level of type there is a single measured value
## therefore, only the first is used i.e. results$sd.obs[subscripts[1]]
## This does not matter if normalise = TRUE because all sd.obs = 1.
## The data frame 'results' should contain a grouping variable 'MyGroupVar',
## 'type' e.g. season, R (correlation coef), sd.obs and sd.mod
xcurve <- cos(seq(0, pi / 2, by = 0.01)) * maxsd
ycurve <- sin(seq(0, pi / 2, by = 0.01)) * maxsd
llines(xcurve, ycurve, col = "black")
xcurve <- cos(seq(0, pi / 2, by = 0.01)) * results$sd.obs[subscripts[1]]
ycurve <- sin(seq(0, pi / 2, by = 0.01)) * results$sd.obs[subscripts[1]]
llines(xcurve, ycurve, col = "black", lty = 5)
corr.lines <- c(0.2, 0.4, 0.6, 0.8, 0.9)
## grid line with alpha transparency
theCol <- t(col2rgb(cor.col)) / 255
for (gcl in corr.lines) llines(
c(0, maxsd * gcl), c(0, maxsd * sqrt(1 - gcl ^ 2)),
col = rgb(theCol, alpha = 0.4), alpha = 0.5
)
bigtick <- acos(seq(0.1, 0.9, by = 0.1))
medtick <- acos(seq(0.05, 0.95, by = 0.1))
smltick <- acos(seq(0.91, 0.99, by = 0.01))
lsegments(
cos(bigtick) * maxsd, sin(bigtick) *
maxsd, cos(bigtick) * 0.96 * maxsd, sin(bigtick) * 0.96 * maxsd,
col = cor.col
)
lsegments(
cos(medtick) * maxsd, sin(medtick) *
maxsd, cos(medtick) * 0.98 * maxsd, sin(medtick) * 0.98 * maxsd,
col = cor.col
)
lsegments(
cos(smltick) * maxsd, sin(smltick) *
maxsd, cos(smltick) * 0.99 * maxsd, sin(smltick) * 0.99 * maxsd,
col = cor.col
)
## arcs for standard deviations (3 by default)
gamma <- pretty(c(0, maxsd), n = 5)
if (gamma[length(gamma)] > maxsd) {
gamma <- gamma[-length(gamma)]
}
labelpos <- seq(45, 70, length.out = length(gamma))
## some from plotrix
for (gindex in 1:length(gamma)) {
xcurve <- cos(seq(0, pi, by = 0.03)) * gamma[gindex] +
results$sd.obs[subscripts[1]]
endcurve <- which(xcurve < 0)
endcurve <- ifelse(length(endcurve), min(endcurve) - 1, 105)
ycurve <- sin(seq(0, pi, by = 0.03)) * gamma[gindex]
maxcurve <- xcurve * xcurve + ycurve * ycurve
startcurve <- which(maxcurve > maxsd * maxsd)
startcurve <- ifelse(length(startcurve), max(startcurve) + 1, 0)
llines(
xcurve[startcurve:endcurve], ycurve[startcurve:endcurve],
col = rms.col, lty = 5
)
ltext(
xcurve[labelpos[gindex]], ycurve[labelpos[gindex]],
gamma[gindex],
cex = 0.7, col = rms.col, pos = 1,
srt = 0, font = 2
)
ltext(
1.1 * maxsd, 1.05 * maxsd,
labels = annotate, cex = 0.7,
col = rms.col, pos = 2
)
}
## angles for R key
angles <- 180 * c(bigtick, acos(c(0.95, 0.99))) / pi
ltext(
cos(c(bigtick, acos(c(0.95, 0.99)))) *
1.06 * maxsd, sin(c(bigtick, acos(c(0.95, 0.99)))) *
1.06 * maxsd, c(seq(0.1, 0.9, by = 0.1), 0.95, 0.99),
cex = 0.7,
adj = 0.5, srt = angles, col = cor.col
)
ltext(
0.82 * maxsd, 0.82 * maxsd, "Correlation",
srt = 315, cex = 0.7,
col = cor.col
)
## measured point and text
lpoints(results$sd.obs[subscripts[1]], 0, pch = 20, col = "purple", cex = 1.5)
ltext(results$sd.obs[subscripts[1]], 0, "Observed", col = "purple", cex = 0.7, pos = 3)
}
panel.taylor <- function(x, y, subscripts, results, results.new, maxsd, cor.col,
rms.col, combine, col.symbol, myColors, group.number,
type, arrow.lwd, ...) {
R <- NULL
sd.mod <- NULL ## avoid R NOTEs
## Plot actual results by type and group if given
results <- transform(results, x = sd.mod * R, y = sd.mod * sin(acos(R)))
if (combine) {
results.new <- transform(results.new, x = sd.mod * R, y = sd.mod * sin(acos(R)))
larrows(
results$x[subscripts], results$y[subscripts],
results.new$x[subscripts], results.new$y[subscripts],
angle = 30, length = 0.1, col = myColors[group.number], lwd = arrow.lwd
)
} else {
lpoints(
results$x[subscripts], results$y[subscripts],
col.symbol = myColors[group.number], ...
)
}
}
startYear <- function(dat) as.numeric(format(min(dat[order(dat)]), "%Y"))
endYear <- function(dat) as.numeric(format(max(dat[order(dat)]), "%Y"))
startMonth <- function(dat) as.numeric(format(min(dat[order(dat)]), "%m"))
endMonth <- function(dat) as.numeric(format(max(dat[order(dat)]), "%m"))
## these are pre-defined type that need a field "date"; used by cutData
dateTypes <- c("year", "hour", "month", "season", "weekday", "weekend",
"monthyear", "gmtbst", "bstgmt", "dst", "daylight",
"seasonyear", "yearseason")
checkPrep <- function(mydata, Names, type, remove.calm = TRUE, remove.neg = TRUE,
strip.white = TRUE, wd = "wd") {
## deal with conditioning variable if present, if user-defined, must exist in data
## pre-defined types
## existing conditioning variables that only depend on date (which is checked)
conds <- c(
"default", "year", "hour", "month", "season", "weekday",
"weekend", "monthyear", "gmtbst", "bstgmt", "dst", "daylight",
"yearseason", "seasonyear"
)
all.vars <- unique(c(names(mydata), conds))
varNames <- c(Names, type) ## names we want to be there
matching <- varNames %in% all.vars
if (any(!matching)) {
## not all variables are present
stop(cat("Can't find the variable(s)", varNames[!matching], "\n"))
}
## add type to names if not in pre-defined list
if (any(type %in% conds == FALSE)) {
ids <- which(type %in% conds == FALSE)
Names <- c(Names, type[ids])
}
## if type already present in data frame
if (any(type %in% names(mydata))) {
ids <- which(type %in% names(mydata))
Names <- unique(c(Names, type[ids]))
}
## just select data needed
mydata <- mydata[, Names]
## if site is in the data set, check none are missing
## seems to be a problem for some KCL data...
if ("site" %in% names(mydata)) { ## split by site
## remove any NA sites
if (anyNA(mydata$site)) {
id <- which(is.na(mydata$site))
mydata <- mydata[-id, ]
}
}
## sometimes ratios are considered which can results in infinite values
## make sure all infinite values are set to NA
mydata[] <- lapply(mydata, function(x) {
replace(x, x == Inf | x == -Inf, NA)
})
if ("ws" %in% Names) {
if ("ws" %in% Names & is.numeric(mydata$ws)) {
## check for negative wind speeds
if (any(sign(mydata$ws[!is.na(mydata$ws)]) == -1)) {
if (remove.neg) { ## remove negative ws only if TRUE
warning("Wind speed <0; removing negative data")
mydata$ws[mydata$ws < 0] <- NA
}
}
}
}
## round wd to make processing obvious
## data already rounded to nearest 10 degress will not be affected
## data not rounded will be rounded to nearest 10 degrees
## assumes 10 is average of 5-15 etc
if (wd %in% Names) {
if (wd %in% Names & is.numeric(mydata[, wd])) {
## check for wd <0 or > 360
if (any(sign(mydata[[wd]][!is.na(mydata[[wd]])]) == -1 |
mydata[[wd]][!is.na(mydata[[wd]])] > 360)) {
warning("Wind direction < 0 or > 360; removing these data")
mydata[[wd]][mydata[[wd]] < 0] <- NA
mydata[[wd]][mydata[[wd]] > 360] <- NA
}
if (remove.calm) {
if ("ws" %in% names(mydata)) {
mydata[[wd]][mydata$ws == 0] <- NA ## set wd to NA where there are calms
mydata$ws[mydata$ws == 0] <- NA ## remove calm ws
}
mydata[[wd]][mydata[[wd]] == 0] <- 360 ## set any legitimate wd to 360
## round wd for use in functions - except windRose/pollutionRose
mydata[[wd]] <- 10 * ceiling(mydata[[wd]] / 10 - 0.5)
mydata[[wd]][mydata[[wd]] == 0] <- 360 # angles <5 should be in 360 bin
}
mydata[[wd]][mydata[[wd]] == 0] <- 360 ## set any legitimate wd to 360
}
}
## make sure date is ordered in time if present
if ("date" %in% Names) {
if ("POSIXlt" %in% class(mydata$date)) {
stop("date should be in POSIXct format not POSIXlt")
}
## if date in format dd/mm/yyyy hh:mm (basic check)
if (length(grep("/", as.character(mydata$date[1]))) > 0) {
mydata$date <- as.POSIXct(strptime(mydata$date, "%d/%m/%Y %H:%M"), "GMT")
}
## try and work with a factor date - but probably a problem in original data
if (is.factor(mydata$date)) {
warning("date field is a factor, check date format")
mydata$date <- as.POSIXct(mydata$date, "GMT")
}
mydata <- arrange(mydata, date)
## make sure date is the first field
if (names(mydata)[1] != "date") {
mydata <- mydata[c("date", setdiff(names(mydata), "date"))]
}
## check to see if there are any missing dates, stop if there are
ids <- which(is.na(mydata$date))
if (length(ids) > 0) {
mydata <- mydata[-ids, ]
warning(paste(
"Missing dates detected, removing",
length(ids), "lines"
), call. = FALSE)
}
## daylight saving time can cause terrible problems - best avoided!!
if (any(dst(mydata$date))) {
warning("Detected data with Daylight Saving Time, converting to UTC/GMT")
mydata$date <- lubridate::force_tz(mydata$date, tzone = "GMT")
}
}
if (strip.white) {
## set panel strip to white
suppressWarnings(trellis.par.set(list(strip.background = list(col = "white"))))
}
## return data frame
return(mydata)
}
# function to check variables are numeric, if not force with warning
checkNum <- function(mydata, vars) {
for (i in seq_along(vars)) {
if (!is.numeric(mydata[[vars[i]]])) {
mydata[[vars[i]]] <- as.numeric(as.character(mydata[[vars[i]]]))
warning(
paste(vars[i], "is not numeric, forcing to numeric..."),
call. = FALSE
)
}
}
return(mydata)
}
## listUpdate function
# [in development]
listUpdate <- function(a, b, drop.dots = TRUE,
subset.a = NULL, subset.b = NULL) {
if (drop.dots) {
a <- a[names(a) != "..."]
b <- b[names(b) != "..."]
}
if (!is.null(subset.a)) {
a <- a[names(a) %in% subset.a]
}
if (!is.null(subset.b)) {
b <- b[names(b) %in% subset.b]
}
if (length(names(b) > 0)) {
a <- modifyList(a, b)
}
a
}
Then use the following code for plotting
TaylorDiagram1(data, obs = "Observed", mod = "Predicted", group = "Method", type = "Station",
scales=list(alternating=1),normalise = TRUE,fontsize=12,
rms.col="black",auto.text=F,xlab="Standard deviation",
cex = 1, ylab="Standard deviation",par.settings = list( grid.pars = list(fontfamily = "serif")))