|
|
Line 11: |
Line 11: |
| ==Answer== | | ==Answer== |
| | | |
− | <rcode name="answer" embed=1> | + | <rcode name="answer" embed=0> |
| | | |
| library(OpasnetUtils) | | library(OpasnetUtils) |
Line 108: |
Line 108: |
| } | | } |
| | | |
− | objects.store(ograph, fillna, collapsemarg) | + | 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. |
| + | ) { |
| + | 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_name <- name[i] |
| + | pt_description <- description[i] |
| + | pt_style <- paste("#style", ifelse(length(icon) == 1, 1, i), sep = "") |
| + | kml <- append(kml, "<Placemark>") |
| + | kml <- append(kml, paste(" <description><![CDATA[",pt_description, "]]></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) |
| + | } |
| + | |
| + | objects.store(ograph, fillna, collapsemarg, MyPointKML, ova2spat) |
| | | |
− | cat("The following objects are stored: ograph, fillna, collapsemarg.\n") | + | cat("The following objects are stored: ograph, fillna, collapsemarg, MyPointKML, ova2spat.\n") |
| | | |
| </rcode> | | </rcode> |
Which functions are so useful that they should be taken into OpasnetUtils package? This page contains draft function which will be included when they are good enough and found important.
+ 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.
# object is the data.frame, marginals is a vector of columns (either column names or positions) that are to be filled.
# This version of fillna accepts column positions (as the previous version) and also column names in marginals.
fillna <- function (object, marginals) {
a <- dropall(object)
if(!is.numeric(marginals)) marginals <- match(marginals, colnames(object))
for (i in marginals) {
a[[i]] <- as.factor(a[[i]])
a1 <- a[!is.na(a[[i]]), ]
a2 <- a[is.na(a[[i]]), ][-i]
addition <- data.frame(A = levels(a[[i]]))
colnames(addition) <- colnames(a)[i]
a2 <- merge(addition, a2)
a <- rbind(a1, a2)
}
return(a)
}
## 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.
) {
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_name <- name[i]
pt_description <- description[i]
pt_style <- paste("#style", ifelse(length(icon) == 1, 1, i), sep = "")
kml <- append(kml, "<Placemark>")
kml <- append(kml, paste(" <description><![CDATA[",pt_description, "]]></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)
}
objects.store(ograph, fillna, collapsemarg, MyPointKML, ova2spat)
cat("The following objects are stored: ograph, fillna, collapsemarg, MyPointKML, ova2spat.\n")
| |