+ Show code- Hide code
library(OpasnetUtils)
ograph <- function( # Määritellään yleisfunktio peruskuvaajan piirtämiseen.
ovariable,
x,
y = character(),
type = character(),
other = character(),
fill = NA,
...
) {
if(class(ovariable) == "ovariable") {
if(nrow(ovariable@output) == 0) ovariable <- EvalOutput(ovariable)
data <- ovariable@output
title <- ovariable@name
if(length(y) == 0) y <- paste(title, "Result", sep = "")
} else {
data <- ovariable
title <- character()
if(length(y) == 0) y <- "Result"
}
if(length(type) == 0) {
if("Iter" %in% colnames(data)) type <- geom_boxplot() else type <- geom_bar(stat = "identity")
}
out <- ggplot(data, aes_string(x = x, y = y, fill = fill)) # Määritellään kuvan sarakkeet
out <- out + type
out <- out + theme_grey(base_size=24) # Fontin kokoa suurennetaan
out <- out + labs(
title = title,
y = paste(unique(data[[paste(title, "Yksikkö", sep = "")]]), sep = "", collapse = ", ")
)
out <- out + theme(axis.text.x = element_text(angle = 90, hjust = 1)) # X-akselin tekstit käännetään niin että mahtuvat
if(length(other) != 0) out <- out + other
return(out)
}
# fillna takes a data.frame and fills the cells with NA with each level in that column.
# fillna was updated in OpasnetUtils and therefore removed from here.
## collapsemarg is a placeholder for a better functionality within CollapseMarginals.
## It takes an ovariable, and summarises all indices in cols using tapply and a user-defined function.
## However, you can also use function "pick" to select locations defined in a list picks found in indices cols.
## Function "unkeep" simply drops the unkept indices without any other operation.
## The output is an ovariable with the same name as the input.
## This was first created for [[:op_fi:Radonin terveysvaikutukset]]
collapsemarg <- function(variable, cols, fun = "sum", picks = list(), ...) { # cols is a character vector, while probs is a list
out <- dropall(variable@output)
marginals <- colnames(out)[variable@marginal]
if(tolower(fun) == "unkeep") { # The function must be a string, otherwise this row will fail.
out <- out[!colnames(out) %in% cols]
} else {
if(tolower(fun) == "pick") {
for(i in cols) {
out <- out[out[[i]] %in% picks[[match(i, cols)]] , ]
}
cols <- "" # Those locations that were picked are still marginals.
} else {
margtemp <- colnames(out)[colnames(out) %in% marginals & !colnames(out) %in% cols]
# You must leave at least one index.
out <- as.data.frame(as.table(tapply(result(variable), out[margtemp], fun)))
out <- out[!is.na(out$Freq) , ]
colnames(out)[colnames(out) == "Freq"] <- ifelse(
length(variable@name) == 0,
"Result",
paste(variable@name, "Result", sep = "")
)
}
}
variable@output <- out
variable@marginal <- colnames(out) %in% marginals & ! colnames(out) %in% cols
return(variable)
}
MyPointKML <- function( # The function creates a KML fille from a SpatialPointsDataFrame object.
obj = NULL, # Spatial object with the data. A SpatialPointsDataFrame.
kmlname = "", # Name of the KML fille (does this show on the map?)
kmldescription = "", # Description of the KML fille (does this show on the map?)
name = NULL, # Name for each datapoint (vector with the same length as data in obj).
description = "", # Descrtion of each datapoint (vector with the same length as data in obj).
icon = "http://maps.google.com/mapfiles/kml/pal4/icon24.png", # Icon shown on pin (?)
col=NULL # I don't know what this does.
) {
cat("This function MyPointKML is depreciated. Use google.point_kml in OpasnetUtilsExt instead.\n")
if (is.null(obj))
return(list(header = c("<?xml version=\"1.0\" encoding=\"UTF-8\"?>",
"<kml xmlns=\"http://earth.google.com/kml/2.2\">",
"<Document>", paste("<name>", kmlname, "</name>",
sep = ""), paste("<description><![CDATA[", kmldescription,
"]]></description>", sep = "")), footer = c("</Document>",
"</kml>")))
if (class(obj) != "SpatialPointsDataFrame")
stop("obj must be of class 'SpatialPointsDataFrame' [package 'sp']")
if (is.null(name)) {
name = c()
for (i in 1:nrow(obj)) name <- append(name, paste("site",
i))
}
if (length(name) < nrow(obj)) {
if (length(name) > 1)
warning("kmlPoints: length(name) does not match nrow(obj). The first name will be replicated.")
name <- rep(name, nrow(obj))
}
if (length(description) < nrow(obj)) {
if (length(description) > 1)
warning("kmlPoints: length(description) does not match nrow(obj). The first description will be replicated.")
description <- rep(description, nrow(obj))
}
if (length(icon) < nrow(obj)) {
if (length(icon) > 1)
warning("kmlPoints: length(icon) does not match nrow(obj). Only the first one will be used.")
icon <- icon[1]
}
# This is some kind of a colour definition
col2kmlcolor <- function(col)
paste(rev(sapply(
col2rgb(col, TRUE),
function(x) sprintf("%02x", x))
), collapse = "")
kml <- kmlStyle <- ""
# Create the KML fille.
kmlHeader <- c("<?xml version=\"1.0\" encoding=\"UTF-8\"?>","<kml xmlns=\"http://earth.google.com/kml/2.2\">", "<Document>")
kmlFooter <- c("</Document>", "</kml>")
# Create rows to the KML fille from data in obj.
for (i in 1:nrow(obj)) {
point <- obj[i, ]
pt_style <- paste("#style", ifelse(length(icon) == 1, 1, i), sep = "")
kml <- append(kml, "<Placemark>")
kml <- append(kml, paste(
" <description><![CDATA[",
name[i],
": ",
description[i],
"]]></description>",
sep = ""
))
#kml <- append(kml, "<Style><IconStyle>")
#kml <- append(kml, paste("<color>", col2kmlcolor(col[i]), "</color>", sep =""))
#kml <- append(kml, paste(" <Icon><href>", icon, "</href></Icon>", sep = ""))
#kml <- append(kml, "<scale>0.300000</scale>")
#kml <- append(kml, "</IconStyle></Style>")
kml <- append(kml, " <Point>")
kml <- append(kml, " <coordinates>")
kml <- append(kml, paste(point@coords[1], point@coords[2], sep = ","))
kml <- append(kml, " </coordinates>")
kml <- append(kml, " </Point>")
kml <- append(kml, "</Placemark>")
}
return(paste(paste(c(kmlHeader, kmlStyle, kml, kmlFooter), sep = "", collapse = "\n"), collapse="\n", sep = ""))
}
ova2spat <- function( # This function converts an ovariable into a SpatialPointsDataFrame.
ovariable, # An evaluated ovariable that has coordinate indices.
coords, # The names of the coordinate indices as a character vector, first x then y.
proj4string # Projection identifier or specification as character string. See http://spatialreference.org/
) {
temp <- ovariable@output
# Transform coordinates into numeric format.
for(i in coords) {
if(is(temp[[i]], "factor")) temp[[i]] <- levels(temp[[i]])[temp[[i]]]
if(is(temp[[i]], "character")) temp[[i]] <- as.numeric(temp[[i]])
}
# Define the coordinate points first, then add other ovariable output to it.
sp <- SpatialPoints(temp[coords], CRS(proj4string))
out <- SpatialPointsDataFrame(sp, temp[!colnames(temp) %in% coords])
#Transform the projection to longitude-latitude system.
epsg4326String <- CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")
out <- spTransform(out,epsg4326String)
return(out)
}
# MyRmap is a function for creating static Google maps as png.
# It is based on MyMap function without the "file destination" parameter
# Requires RgoogleMaps package
MyRmap <- function (
shp, # a spatial data object
plotvar, # Name of the column that has the values to be illustrated on the map
pch = 19, # Shape of the point (19: circle)
cex = 0.3, # Size of the point
legend_title = "", # Title of the legend
legend_position = "topleft",
numbins = 8, # Number of colour bins in graph
center, # center of the map
size = c(640, 480), # size of the map. This produces the right dimensions in Opasnet.
MINIMUMSIZE = FALSE,
RETURNIMAGE = TRUE,
GRAYSCALE = FALSE,
NEWMAP = TRUE,
zoom,
verbose = 1,
...
) {
plotvar <- shp[[plotvar]]
plotclr <- brewer.pal(numbins, "Spectral")
classes <- classIntervals(plotvar, numbins, style = "quantile")
colcode <- findColours(classes, plotclr)
latR <- shp@coords[ , 2]
lonR <- shp@coords[ , 1]
#get the bounding box:
bb <- qbbox(lat = latR, lon = lonR)
if (missing(zoom))
zoom <- min(MaxZoom(latR, lonR, size))
if (missing(center)) {
lat.center <- mean(latR)
lon.center <- mean(lonR)
}
else {
lat.center <- center[1]
lon.center <- center[2]
}
if (MINIMUMSIZE) {
ll <- LatLon2XY(latR[1], lonR[1], zoom) # I think the latR and lonR are used here differently than how they
ur <- LatLon2XY(latR[2], lonR[2], zoom) # are used elsewhere. Thus, if MINIMUMSIZE = TRUE, you may see problems.
cr <- LatLon2XY(lat.center, lon.center, zoom)
ll.Rcoords <- Tile2R(ll, cr)
ur.Rcoords <- Tile2R(ur, cr)
if (verbose > 1) {
cat("ll:")
print(ll)
print(ll.Rcoords)
cat("ur:")
print(ur)
print(ur.Rcoords)
cat("cr:")
print(cr)
}
size[1] <- 2 * max(c(ceiling(abs(ll.Rcoords$X)), ceiling(abs(ur.Rcoords$X)))) + 1
size[2] <- 2 * max(c(ceiling(abs(ll.Rcoords$Y)), ceiling(abs(ur.Rcoords$Y)))) + 1
if (verbose) cat("new size: ", size, "\n")
}
MyMap <- GetMap(
center = c(lat.center, lon.center),
zoom = zoom,
size = size,
RETURNIMAGE = RETURNIMAGE,
GRAYSCALE = GRAYSCALE,
verbose = verbose,
...
)
PlotOnStaticMap(MyMap) # Plot an empty map.
PlotOnStaticMap( # Plot the data points on the map.
MyMap,
lat = latR,
lon = lonR,
pch = pch,
cex = cex,
col = colcode,
add = T
)
legend( # Plot the legend on the map.
legend_position,
legend = names(attr(colcode, "table")),
title = legend_title,
fill = attr(colcode, "palette"),
cex = 1.0,
bty = "y",
bg = "white"
)
}
MyPlotKML <- function(
shp, # a SpatialPointDataFrame object.
result = "Result", # The name of result column in shp.
rasterization = TRUE, # Whether to rasterize the data or not.
ncols = 32, # Number or columns in the raster.
nrows = 32, # Number of rows in the raster.
fun = mean # function to aggregate data points to the raster.
) {
cat("Consider merging this function MyPolotKML with google.show_raster_on_maps in OpasnetUtilsExt.\n")
if(rasterization) {
#Create blank raster
rast <- raster()
#Set raster extent to that of point data
extent(rast) <-extent(shp)
#Choose number of columns and rows
ncol(rast) <- ncols
nrow(rast) <- nrows
#Rasterize point data
rast2 <- rasterize(shp, rast, shp[[result]], fun = fun)
}
start <- 0 # min(shp[[result]])
end <- max(shp[[result]])
steps <- approx(c(start,end),n=6)$y
colors <- rev(rainbow(length(steps), start=0, end=0.50))
# Create the colorstrip below the map.
par(mfrow=c(6,1), mar=c(3,1,0,1), cex = 1.5)
colorstrip <- function(colors, labels)
{
count <- length(colors)
image(
matrix(1:count, count, 1),
col = colors,
ylab = "",
axes = FALSE
)
axis(1,approx(c(0, 1), n=length(labels))$y, labels)
}
colorstrip(colors, steps)
#Plot data
google.show_raster_on_maps(rast2, col = colors, style = "height:500px;")
}
# Merge all but show_bins largest bins of indices cols to 'Other'.
truncateIndex <- function( # Truncates an index to contain only the largest index bins.
obj, # ovariable to use.
cols, # names of the columns to truncate.
bins = 10# Number of bins to show. Other bins will be merged to "Other".
) {
for(i in 1:length(cols))
{
sums <- as.data.frame(as.table(tapply(result(obj), obj@output[cols[i]], sum)))
bins <- min(bins, length(levels(obj@output[[cols[i]]])))
limit <- sort(sums$Freq, decreasing = TRUE)[bins]
keeps <- sums[sums$Freq > limit , cols[i]]
keeps <- levels(keeps)[keeps]
levels(obj@output[[cols[i]]]) <- ifelse(
levels(obj@output[[cols[i]]]) %in% keeps,
levels(obj@output[[cols[i]]]),
"Other"
)
}
return(obj)
}
findrest <- function (X, cols, total = 1)
{
# findrest input is an ovariable that can be integrated over indices cols to result in total.
# Often it is used with uncertain fractions. The largest fraction is omitted or NA, and it is replaced by whatever is missing from the total.
if (nrow(X@output) == 0)
X <- EvalOutput(X)
rescol <- comment(result(X))
marginals <- colnames(X@output)[X@marginal]
# temp is the amount that is still missing from the total.
temp <- total - oapply(X, cols = cols, FUN = function(x) sum(x, na.rm = TRUE))
temp <- unkeep(temp, cols = rescol) # Remove old rescol because it would cause trouble later.
colnames(temp@output)[colnames(temp@output) == "Result"] <- "tempResult"
temp@name <- "temp" # This is to make sure that merge works.
out <- merge(X, temp)@output
# Replace missing values with values from temp.
out[[rescol]] <- ifelse(is.na(out[[rescol]]), out$tempResult, out[[rescol]]) # Result comes from temp
out$tempResult <- NULL
X@output <- out
X@marginal <- colnames(X@output) %in% marginals
return(X)
}
unkeep <- function (X, cols = NA, sources = FALSE, prevresults = FALSE)
{
rescol <- paste(X@name, "Result", sep = "")
if (sources)
cols <- c(cols, colnames(X@output)[grepl("Source$", colnames(X@output))])
for(i in cols) { # Give warning about unkept indices with >1 locations.
if(
length(unique(X@output[[i]])) > 1 &
X@marginal[match(i, colnames(X@output))]
) {
warning(paste(
"There is >1 unique locations in column",
i, ":",
paste(as.character(unique(X@output[[i]])), collapse = ", ")
))
}
}
if (prevresults)
cols <- c(cols, colnames(X@output)[grepl("Result$", colnames(X@output)) &
colnames(X@output) != rescol])
marginals <- colnames(X@output)[X@marginal]
X@output <- X@output[!colnames(X@output) %in% cols]
X@marginal <- colnames(X@output) %in% marginals
return(X)
}
timing <- function(dat, timecol = NA, weeks = 6, tz = "EET")
# timing converts character or numeric inputs into times using a few default formats
{
if(is.data.frame(dat)) # Turn dat into a data.frame in all cases.
{
timesall <- (dat[timecol])
} else {
timesall <- data.frame(Timecol = dat)
timecol <- "Timecol"
}
temprow <- character() # A whole row of timesall collapsed into a string.
for(i in 1:nrow(timesall))
{
temprow[i] <- tolower(paste(t(timesall)[ , i], collapse = ""))
}
weekdays <- data.frame(
Name = c("su", "ma", "ti", "ke", "to", "pe", "la",
"sun", "mon", "tue", "wed", "thu", "fri", "sat",
"sön", "mon", "tis", "ons", "tor", "fre", "lör"),
Number = rep(0:6, times = 3)
)
# day is the number of the weekday in case of repeating events.
day <- rep(NA, nrow(timesall))
for(i in 1:nrow(weekdays))
{
temp1 <- grepl(weekdays$Name[i], temprow) # Is any weekday mentioned in temprow?
day <- ifelse(is.na(day) & temp1, weekdays$Number[i], day) # Find the weekday number.
}
# repall are repeating events, x are non-repeating events.
repall <- timesall[!is.na(day) , ]
xall <- timesall[is.na(day) , ]
starting <- NA
########### First, change non-repeating timedates.
# Change timedate into POSIXct assuming formats 15.3.2013 or 2013-03-15 and 15:24 or 15.24.
# Note! 13 and 2013 mean 1.1.2013 and 3.2013 means 1.3.2013
if(nrow(xall) > 0)
{
xout <- data.frame(Datrow = (1:nrow(timesall))[is.na(day)]) # Row numbers from dat.
for(j in colnames(xall))
{
x <- xall[[j]]
if(is.factor(x)) x <- levels(x)[x]
x <- ifelse(grepl("^[0-9][0-9]$", x), paste("20", x, sep = ""), x)
x <- ifelse(grepl("^[0-9][0-9][0-9][0-9]$", x), paste("1.1.", x, sep = ""), x)
x <- ifelse(grepl("^[0-9].[0-9][0-9][0-9][0-9]$", x), paste("1.", x, sep = ""), x)
x <- ifelse(grepl("^[0-9][0-9].[0-9][0-9][0-9][0-9]$", x), paste("1.", x, sep = ""), x)
temp <- x
x <- as.POSIXct(temp, format = "%d.%m.%Y %H:%M", tz = tz)
x <- ifelse(!is.na(x), x, as.POSIXct(temp, format = "%d.%m.%Y %H.%M", tz = tz))
x <- ifelse(!is.na(x), x, as.POSIXct(temp, format = "%Y-%m-%d %H:%M", tz = tz))
x <- ifelse(!is.na(x), x, as.POSIXct(temp, format = "%Y-%m-%d %H.%M", tz = tz))
x <- ifelse(!is.na(x), x, as.POSIXct(temp, format = "%d.%m.%Y", tz = tz))
x <- ifelse(!is.na(x), x, as.POSIXct(temp, format = "%d.%m.%y", tz = tz))
xout <- cbind(xout, X = as.POSIXct(x, origin = "1970-01-01", tz = tz))
# Intermediate values turn into numeric, therefore turned back to POSIX.
starting <- min(c(starting, xout$X), na.rm = TRUE)
colnames(xout)[colnames(xout) == "X"] <- j
}
}
############## Then, change weekly repeating timedates.
# repall must have format ma 9:00 or TUESDAY 8.24. Weekday is case-insensitive and can be abbrevieated.
# The start and end times are assumed to be on the same day. The name of day can be on either column.
if(nrow(repall) > 0)
{
for(j in colnames(repall))
{
reptime <- gsub("[[:alpha:] ]", "", repall[[j]]) # Remove alphabets and spaces.
reptime <- gsub("\\.", ":", reptime)
reptime <- strsplit(reptime, split = ":")
temp2 <- numeric()
for(i in 1:length(reptime))
{
temp2[i] <- as.numeric(reptime[[i]][1]) * 3600 + as.numeric(reptime[[i]][2]) * 60
}
reptime <- temp2
if(is.na(starting)) starting <- paste(format(Sys.Date(), format = "%Y"), "-01-01", sep = "")
starting <- as.POSIXlt(starting, origin = "1970-01-01") # First day of year.
starting$mday <- starting$mday - as.numeric(format(starting, format = "%w")) + day[!is.na(day)] # Previous Sunday plus weekdaynumber.
reps <- data.frame()
temp3 <- starting
for(i in 1:weeks)
{
reps <- rbind(reps, data.frame(
Datrow = (1:nrow(timesall))[!is.na(day)],
X = as.POSIXct(temp3, origin = "1970-01-01", tz = tz) + reptime
))
temp3$mday <- temp3$mday + 7 # Make a weekly event.
}
colnames(reps)[colnames(reps) == "X"] <- j
if(j == colnames(repall)[1]) repout <- reps else repout <- cbind(repout, reps[j])
}
}
out <- rbind(xout, repout)
if(is.data.frame(dat))
{
dat$Datrow <- 1:nrow(dat)
dat <- dat[!colnames(dat) %in% timecol]
out <- merge(dat, out)
out <- out[colnames(out) != "Datrow"]
} else {
out <- out[[timecol]]
}
return(out)
}
# Funktio makeTimeline ottaa tapahtumalistauksen ja rakentaa siitä aikajanan. Parametrit:
# event = data.framena tapahtumalistaus, joka sisältää ainakin alku- ja loppuajan (Alku, Loppu) ja
# tapahtumatiedon sekä mahdollisesti toiston ja keston (Toisto = aikaväli päivinä,
# Kesto = viimeinen tapahtuma-aika).
# timeformat = jos TRUE, oletetaan POSIX-muotoiseksi ja muutetaan operointia varten sekunneiksi.
# Jos FALSE, oletetaan reaaliluvuksi ja operoidaan suoraan luvuilla.
makeTimeline <- function(event, timeformat = TRUE) {
# eventiin luodaan Toisto ja Kesto, jos jompikumpi puuttuu.
if(!all(c("Toisto", "Kesto") %in% colnames(event)))
{
event$Toisto <- NA
event$Kesto <- NA
}
if(timeformat)
{
for(m in c("Alku", "Loppu", "Kesto"))
{
event[[m]] <- as.double(as.POSIXct(event[[m]])) # Muutetaan aika sekunneiksi.
}
event$Toisto <- event$Toisto * 3600 * 24 # Muutetaan Toisto päivistä sekunneiksi.
}
# Jos on puuttuvaa tietoa kestosta tai toistosta, korvataan inertillä datalla.
test <- event$Toisto == 0 | event$Kesto == 0 | is.na(event$Toisto) | is.na(event$Kesto)
event$Toisto <- ifelse(test, 1, event$Toisto)
event$Kesto <- ifelse(test, event$Alku, event$Kesto)
# Luodaan aikajanan alkupiste. Eventrow otetaan aikanaan tyhjältä riviltä.
timeline <- data.frame(Time = min(event$Alku), Eventrow = nrow(event)+1)
for(i in 1:nrow(event)) { # Toista jokaiselle havaintoriville
times <- 0:floor((event$Kesto[i] - event$Alku[i]) / event$Toisto[i]) # Toistojen määrä
# Toista tapahtumaa Kestoon asti.
temp <- data.frame(
Time = event$Alku[i] + times * event$Toisto[i],
End = event$Loppu[i] + times * event$Toisto[i],
EventrowStart = i
)
timeline <- merge(timeline, temp[ , c("Time", "EventrowStart")], all = TRUE) # Lisätään tapahtumat aikajanaan.
colnames(temp) <- c("Remove", "Time", "EventrowEnd") # Muutetaan otsikot, koska nyt halutaan mergata loppuhetket aikajanaan.
timeline <- merge(timeline, temp[, c("Time", "EventrowEnd")], all = TRUE)
for(j in 2:nrow(timeline)) {
# Tämä luuppi käy aikajanan läpi ja täydentää tapahtumat.
# Ensin kaikkiin uusiin aikapisteisiin jatketaan sitä aiempaa toimintaa, joka oli menossa edellisessä pisteessä.
if(is.na(timeline$Eventrow[j]))
{
timeline$Eventrow[j] <- timeline$Eventrow[j-1]
}
# Sitten jatketaan uutta toimintaa niihin uusiin pisteisiin, jotka eivät ole loppupisteitä.
if(is.na(timeline$EventrowStart[j]) & is.na(timeline$EventrowEnd[j]))
{
timeline$EventrowStart[j] <- timeline$EventrowStart[j-1]
}
}
# Jos uutta toimintaa on olemassa, statuksena käytetään sitä, muutoin statusta eli aiempaa toimintaa.
timeline$Eventrow <- ifelse(!is.na(timeline$EventrowStart), timeline$EventrowStart, timeline$Eventrow)
# Leikataan turhat sarakkeet pois ja siirrytään seuraavalle event-riville
timeline <- timeline[ , c("Time", "Eventrow")]
}
event <- rbind(event, rep(NA, ncol(event))) # Lisää rivi loppuhetkeä varten
event$Alku[nrow(event)] <- max(timeline$Time)
event$Eventrow <- row(event)[ , 1]
timeline <- merge(timeline, event) # Yhdistetään Statuksen eli eventin rivinumeron avulla.
timeline <- timeline[!colnames(timeline) %in% c("Eventrow", "Alku", "Loppu", "Toisto", "Kesto")]
timeline <- timeline[order(timeline$Time) , ]
if(timeformat) timeline$Time <- as.POSIXct(timeline$Time, origin = "1970-01-01")
return(timeline)
}
objects.store(ograph, collapsemarg, MyPointKML, ova2spat, MyRmap, MyPlotKML, truncateIndex, findrest,
unkeep, timing, makeTimeline)
cat(paste("The following objects are stored: ograph, collapsemarg, MyPointKML, ova2spat, MyRmap, MyPlotKML,",
"truncateIndex, findrest, unkeep, timing, makeTimeline.\n"))
| |
