Difference between revisions of "OpasnetUtils/Drafts"
From Testiwiki
(→Answer: binoptest function for locating problem in ovariable indices) |
(→Calculations: showind works now) |
||
(5 intermediate revisions by the same user not shown) | |||
Line 13: | Line 13: | ||
Call the objects stored by this code from another rode with this command: | Call the objects stored by this code from another rode with this command: | ||
− | objects.latest("Op_en6007", code_name = "answer") | + | objects.latest("Op_en6007", code_name = "answer") # Old version that fetches all objects, depreciated and not updated. |
+ | objects.latest("Op_en6007", code_name = "diagnostics") # Functions for ovariable and model diagnostics: ovashapetest, showLoctable, binoptest | ||
+ | objects.latest("Op_en6007", code_name = "webropol") # Functions for operating with Webropol data | ||
+ | objects.latest("Op_en6007", code_name = "miscellaneous") # Functions for various tasks | ||
+ | objects.latest("Op_en6007", code_name = "gis") # Functions for ovariable, KML and Googl maps interactions | ||
− | <rcode name=" | + | == Rationale == |
+ | |||
+ | === Calculations === | ||
+ | |||
+ | '''Functions for ovariable diagnostics | ||
+ | showind has problems with get() but this version of code was acceptable [http://en.opasnet.org/en-opwiki/index.php?title=Special:RTools&id=QcfKMkCd2ewUtZqP]. | ||
+ | |||
+ | <rcode name="diagnostics" embed=0> | ||
+ | #This is code Op_en6007/diagnostics on page [OpasnetUtils/Drafts]] | ||
library(OpasnetUtils) | library(OpasnetUtils) | ||
− | ####### | + | # Shows a table about ovariables and their index and location changes compared with parents. |
+ | # showind has problems with get(). | ||
+ | showind <- function(name = ".GlobalEnv", sources = FALSE, prevresults = FALSE) { | ||
+ | # i ovariable | ||
+ | # k parent ovariable | ||
+ | # l index in (parent) ovariable | ||
+ | deptable <- data.frame() | ||
+ | for(i in ls(name = name)) { | ||
+ | d = list(get(i))[[1]] | ||
+ | if(class(d) == "ovariable") { | ||
+ | depind <- list() | ||
+ | if(nrow(d@dependencies)>0) { | ||
+ | dep <- paste(d@dependencies$Name, collapse = ", ") | ||
+ | for(k in d@dependencies$Name){ | ||
+ | if(!exists(k)) cat(k, "does not exist.\n") else { | ||
+ | if(class(get(k)) != "ovariable") cat(k, "is not an ovariable.\n") else { | ||
+ | ko <- list(get(k)@output)[[1]] | ||
+ | if("Iter" %in% colnames(ko)) ko$Iter <- as.factor(max(as.numeric(as.character(ko$Iter)))) | ||
+ | cols <- colnames(ko) | ||
+ | if(!sources) cols <- cols[!grepl("Source$", cols)] | ||
+ | if(!prevresults) cols <- cols[!grepl("Result$", cols)] | ||
+ | for(l in cols) { | ||
+ | if(l %in% names(depind)) { | ||
+ | depind[[l]] <- union(depind[[l]], unique(ko[[l]])) | ||
+ | } else { | ||
+ | newind <- list(unique(ko[[l]])) | ||
+ | names(newind) <- l | ||
+ | depind <- c(depind, newind) | ||
+ | } | ||
+ | } | ||
+ | } | ||
+ | } | ||
+ | } | ||
+ | } else { | ||
+ | dep <- "No dependencies" | ||
+ | } | ||
+ | curcols <- colnames(d@output) | ||
+ | if(!sources) curcols <- curcols[!grepl("Source$", curcols)] | ||
+ | if(!prevresults) curcols <- curcols[!grepl("Result$", curcols)] | ||
+ | droploc <- character() | ||
+ | for(m in curcols) { | ||
+ | if(!is.numeric(d@output[[m]])) { | ||
+ | drops <- setdiff(depind[[m]], unique(d@output[[m]])) | ||
+ | if(length(drops>0)) { | ||
+ | droploc <- paste( | ||
+ | droploc, | ||
+ | paste( | ||
+ | m, | ||
+ | paste(drops, collapse = ", "), | ||
+ | sep = ": " | ||
+ | ), | ||
+ | sep = " | " | ||
+ | ) | ||
+ | } | ||
+ | } | ||
+ | } | ||
+ | if(length(droploc)==0) droploc <- NA | ||
+ | deptable <- rbind( | ||
+ | deptable, | ||
+ | data.frame( | ||
+ | Ovariable = i, | ||
+ | Size = nrow(d@output), | ||
+ | Dependencies = dep, | ||
+ | Current = paste(curcols, collapse = ", "), | ||
+ | Dropped = paste(setdiff(names(depind), curcols), collapse = ", "), | ||
+ | New = paste(setdiff(curcols, names(depind)), collapse = ", "), | ||
+ | Dropped_locations = droploc | ||
+ | ) | ||
+ | ) | ||
+ | } | ||
+ | } | ||
+ | return(deptable) | ||
+ | } | ||
+ | |||
+ | ovashapetest <- function(ova) { | ||
+ | allr <- rownames(ova@output) | ||
+ | uniqr <- rownames(unique(ova@output[ova@marginal])) | ||
+ | cube <- sapply(ova@output[ova@marginal], FUN = function(x) length(unique(x))) | ||
+ | if(length(allr) == length(uniqr)) { | ||
+ | cat("All rows have unique marginals.\n") | ||
+ | } else { | ||
+ | cat("Warning. All rows do not have unique marginals. Make sure that this is what you want.\n") | ||
+ | } | ||
+ | cat("Number of all rows:", length(allr), "\n") | ||
+ | cat("Number of all rows without Iter: Iter==1", length(ova$Iter[ova$Iter=="1"]), | ||
+ | "nrow/N", length(allr)/openv$N, "\n") | ||
+ | cat("Number of unique rows:", length(uniqr), "\n") | ||
+ | cat("Number of rows in a full array:", prod(cube), "\n") | ||
+ | oprint(cube) | ||
+ | nonuniqr <- setdiff(allr, uniqr) | ||
+ | # cat("Non-unique rows:", nonuniqr, "\n") | ||
+ | # oprint(head(ova@output[rownames(ova@output) %in% nonuniqr , ])) | ||
+ | cubesm <- cube[cube>1 & cube<50] | ||
+ | cubn <- names(cubesm) | ||
+ | for(i in 2:(length(cubn))) { | ||
+ | for(j in 1:(i-1)){ | ||
+ | oprint(c(cubn[i], cubn[j])) | ||
+ | oprint(table(ova@output[[cubn[i]]], ova@output[[cubn[j]]], useNA="ifany")) | ||
+ | } | ||
+ | } | ||
+ | |||
+ | for(i in colnames(ova@output)[ova@marginal]) { | ||
+ | locs <- ova@output[[i]] | ||
+ | exper <- prod(cube[names(cube) != i]) | ||
+ | oprint(c(i, exper)) | ||
+ | for(j in unique(ova@output[[i]])) { | ||
+ | cat(j, length(locs[locs == j]), ",") | ||
+ | } | ||
+ | } | ||
+ | } | ||
##################################### | ##################################### | ||
Line 56: | Line 177: | ||
Ovariable = i, | Ovariable = i, | ||
Index = j, | Index = j, | ||
− | Class = class(get(i)@output[[j]]), | + | Class = paste(class(get(i)@output[[j]]), collapse=" "), |
+ | Marginal = j %in% colnames(get(i)@output)[get(i)@marginal], | ||
NumLoc = length(unique(get(i)@output[[j]])), | NumLoc = length(unique(get(i)@output[[j]])), | ||
Locations = paste(head(unique(get(i)@output[[j]])), collapse = " ") | Locations = paste(head(unique(get(i)@output[[j]])), collapse = " ") | ||
Line 67: | Line 189: | ||
return(loctable) | return(loctable) | ||
} | } | ||
+ | |||
+ | objects.store(showind, binoptest, showLoctable, ovashapetest) | ||
+ | cat("Functions showind, binoptest, showLoctable, ovashapetest stored.\n") | ||
+ | </rcode> | ||
+ | |||
+ | '''Functions for Webropol data | ||
+ | |||
+ | <rcode name="webropol" embed=1> | ||
+ | #This is code Op_en6007/webropol on page [OpasnetUtils/Drafts]] | ||
+ | |||
+ | library(OpasnetUtils) | ||
### webropol.convert converts a csv file from Webropol into a useful data.frame. | ### webropol.convert converts a csv file from Webropol into a useful data.frame. | ||
Line 127: | Line 260: | ||
return(dat) | return(dat) | ||
} | } | ||
+ | |||
+ | |||
+ | objects.store(webropol.convert, merge.questions) | ||
+ | cat("Functions webropol.convert, merge.questions stored.\n") | ||
+ | </rcode> | ||
+ | |||
+ | '''Miscellaneous functions | ||
+ | |||
+ | <rcode name="miscellaneous" embed=1> | ||
+ | #This is code Op_en6007/webropol on page [OpasnetUtils/Drafts]] | ||
+ | |||
+ | library(OpasnetUtils) | ||
############ Shuffles columns of a data.frame so that they match a pre-defined correlation matrix | ############ Shuffles columns of a data.frame so that they match a pre-defined correlation matrix | ||
Line 167: | Line 312: | ||
} | } | ||
return(cat("Decisions were forgotten.\n")) | return(cat("Decisions were forgotten.\n")) | ||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
} | } | ||
Line 235: | Line 335: | ||
#DateTime <- as.POSIXct(paste(temperature$Date, temperature$Time), format="%Y-%m-%d %H:%M:%S") | #DateTime <- as.POSIXct(paste(temperature$Date, temperature$Time), format="%Y-%m-%d %H:%M:%S") | ||
#DateHours <- as.POSIXct(paste(price$Date, price$Hours), format="%Y-%m-%d %H:%M:%S") | #DateHours <- as.POSIXct(paste(price$Date, price$Hours), format="%Y-%m-%d %H:%M:%S") | ||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
# fillna takes a data.frame and fills the cells with NA with each level in that column. | # fillna takes a data.frame and fills the cells with NA with each level in that column. | ||
Line 314: | Line 378: | ||
return(variable) | return(variable) | ||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
} | } | ||
Line 958: | Line 747: | ||
} | } | ||
− | + | rm(wiki_username) | |
− | + | objects.store(list = ls()) | |
− | + | cat("All objects in the global namespace were stored:", ls(), "\n") | |
− | + | ||
− | + | </rcode> | |
+ | |||
+ | '''Functions for GIS data | ||
+ | |||
+ | <rcode name="gis" embed=1> | ||
+ | #This is code Op_en6007/gis on page [OpasnetUtils/Drafts]] | ||
+ | |||
+ | library(OpasnetUtils) | ||
+ | |||
+ | 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 or a data.frame into a SpatialPointsDataFrame. | ||
+ | dat, # An evaluated ovariable or data.frame that has coordinate indices. | ||
+ | coords = c("LO", "LA"), # The names of the coordinate indices as a character vector, first x then y. | ||
+ | proj4string = NULL # Projection identifier or specification as character string. See http://spatialreference.org/ | ||
+ | # If proj4string is NULL, longitude-latitude system is assumed. | ||
+ | ) { | ||
+ | if(class(dat) == "ovariable") temp <- dat@output else | ||
+ | if(is.data.frame(dat)) temp <- dat else | ||
+ | stop("object must be either evaluated ovariable or data.frame\n") | ||
+ | |||
+ | # Transform coordinates into numeric format. | ||
+ | |||
+ | for(i in coords) { | ||
+ | temp[[i]] <- as.numeric(as.character(temp[[i]])) | ||
+ | } | ||
+ | |||
+ | # Define the coordinate points first, then add other ovariable output to it. | ||
+ | |||
+ | if(is.null(proj4string)) { | ||
+ | sp <- SpatialPoints(temp[coords], CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")) | ||
+ | } else { | ||
+ | sp <- SpatialPoints(temp[coords], CRS(proj4string)) | ||
+ | } | ||
+ | out <- SpatialPointsDataFrame(sp, temp[!colnames(temp) %in% coords]) | ||
+ | |||
+ | #Transform the projection to longitude-latitude system. | ||
+ | if(!is.null(proj4string)) { | ||
+ | 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] | |
− | |||
− | |||
− | if( | + | #get the bounding box: |
− | + | ||
− | + | bb <- qbbox(lat = latR, lon = lonR) | |
− | if( | + | |
− | + | 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;") | ||
+ | } | ||
+ | objects.store(MyPointKML, ova2spat, MyRmap, MyPlotKML) | ||
+ | cat("Functions MyPointKML, ova2spat, MyRmap, MyPlotKML stored.\n") | ||
</rcode> | </rcode> | ||
Latest revision as of 19:33, 6 June 2017
This page is a method.
The page identifier is Op_en6007 |
---|
Moderator:Jouni (see all) |
Give your opinion to the peer rating of the content of this page. |
Upload data
|
Question
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.
Answer
Call the objects stored by this code from another rode with this command:
objects.latest("Op_en6007", code_name = "answer") # Old version that fetches all objects, depreciated and not updated. objects.latest("Op_en6007", code_name = "diagnostics") # Functions for ovariable and model diagnostics: ovashapetest, showLoctable, binoptest objects.latest("Op_en6007", code_name = "webropol") # Functions for operating with Webropol data objects.latest("Op_en6007", code_name = "miscellaneous") # Functions for various tasks objects.latest("Op_en6007", code_name = "gis") # Functions for ovariable, KML and Googl maps interactions
Rationale
Calculations
Functions for ovariable diagnostics showind has problems with get() but this version of code was acceptable [1].
Functions for Webropol data
Miscellaneous functions
Functions for GIS data
See also
- OpasnetUtils/Ograph, a previous code, now depreciated.
- en:Matrix multiplication in Wikipedia, Matmult in R
References
Related files
<mfanonymousfilelist></mfanonymousfilelist>