1
grid.shape <- function(shp, gp=gpar(), bg.col=NA, i, k) {
2 2
	geoms <- st_geometry(shp)
3
	
4
	
5
	## TO DO relative coordinates
6
	
7 2
	bb <- attr(shp, "bbox")
8
	
9
	# easy fix
10
	# x.b <- 1/ (bb[3] - bb[1])
11
	# x.a <- -bb[1] * x.b
12
	# y.b <- 1/ (bb[4] - bb[2])
13
	# y.a <- -bb[2] * y.b
14 2
	do.call("gList", mapply(function(p, id1) {	
15 2
		gp2 <- lapply(gp, function(g) {
16 2
			if (length(g)==nrow(shp)) g[id1] else g
17 2
		})
18 2
		class(gp2) <- "gpar"
19
		
20 2
		grb <- st_as_grob(p, gp=gp2, name=paste("tm_polygons", i, k, id1, sep="_"))
21
		#grob_mod(grb, x.a=x.a, x.b=x.b, y.a=y.a, y.b=y.b)
22 2
		grb
23
		
24 2
	}, geoms, 1:nrow(shp), SIMPLIFY=FALSE))
25
	
26

27
	
28
	# bb <- bbox(shp)
29
	# do.call("gList", mapply(function(p, id1) {
30
	# 	np <- length(p@Polygons)
31
	# 	co2 <- mapply(function(pp, id2) {
32
	# 		coords <- pp@coords
33
	# 		cbind(coords, id2)
34
	# 	}, p@Polygons, 1:length(p@Polygons), SIMPLIFY=FALSE)
35
	# 	res <- cbind(do.call("rbind", co2))
36
	# 	res[,1] <- (res[,1]-bb[1,1]) / (bb[1,2]-bb[1,1])
37
	# 	res[,2] <- (res[,2]-bb[2,1]) / (bb[2,2]-bb[2,1])
38
	# 	
39
	# 	gp2 <- lapply(gp, function(g) {
40
	# 		if (length(g)==length(shp)) g[id1] else g
41
	# 	})
42
	# 	class(gp2) <- "gpar"
43
	# 	idName <- paste("tm_polygons", i, k, id1, sep="_")
44
	# 	pathGrob(res[,1], res[,2], id=res[,3], gp=gp2, name = idName)
45
	# 	
46
	# }, shp@polygons, 1:length(shp), SIMPLIFY=FALSE))
47
}
48

49

50

51
grid.shplines <- function(shp, gp=gpar(), i, k) {
52 2
	geoms <- st_geometry(shp)
53 2
	bb <- attr(shp, "bbox")
54
	
55
	# easy fix
56
	# x.b <- 1/ (bb[3] - bb[1])
57
	# x.a <- -bb[1] * x.b
58
	# y.b <- 1/ (bb[4] - bb[2])
59
	# y.a <- -bb[2] * y.b
60
	
61 2
	geoms <- st_cast(geoms, "MULTILINESTRING")
62
	
63 2
	do.call("gList", mapply(function(p, id1) {	
64 2
		gp2 <- lapply(gp, function(g) {
65 2
			if (length(g)==nrow(shp)) g[id1] else g
66 2
		})
67 2
		class(gp2) <- "gpar"
68
		
69 2
		grb <- st_as_grob(p, gp=gp2, name=paste("tm_lines", i, k, id1, sep="_"))
70
		#grob_mod(grb, x.a=x.a, x.b=x.b, y.a=y.a, y.b=y.b)
71 2
		grb
72
		
73 2
	}, geoms, 1:nrow(shp), SIMPLIFY=FALSE))
74
	# 
75
	# 
76
	# 
77
	# bb <- bbox(shp)
78
	# do.call("gList", mapply(function(p, id1) {
79
	# 	np <- length(p@Lines)
80
	# 	co2 <- mapply(function(pp, id2) {
81
	# 		coords <- pp@coords
82
	# 		cbind(coords, id2)
83
	# 	}, p@Lines, 1:length(p@Lines), SIMPLIFY=FALSE)
84
	# 	res <- cbind(do.call("rbind", co2), id1)
85
	# 	res[,1] <- (res[,1]-bb[1,1]) / (bb[1,2]-bb[1,1])
86
	# 	res[,2] <- (res[,2]-bb[2,1]) / (bb[2,2]-bb[2,1])
87
	# 
88
	# 	gp2 <- lapply(gp, function(g) {
89
	# 		if (length(g)==length(shp)) rep.int(g[id1], np) else g
90
	# 	})
91
	# 	class(gp2) <- "gpar"
92
	# 	idName <- paste("tm_lines", i, k, id1, sep="_")
93
	# 	polylineGrob(res[,1], res[,2],	id=res[,3], gp=gp2, name=idName)
94
	# }, shp@lines, 1:length(shp), SIMPLIFY=FALSE))
95
}

Read our documentation on viewing source code .

Loading