/
draw_tem.R
157 lines (147 loc) · 5.11 KB
/
draw_tem.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
#' Draw template
#'
#' Visualise a template on an image.
#'
#' @details
#' Visualising the index of each point isn't great yet and will overlay
#'
#' @param stimuli list of stimuli
#' @param pt.color,line.color line or point color, see [color_conv()]
#' @param pt.alpha,line.alpha transparency (0-1), ignored if color is a hex value with transparency. Set alpha to 0 to omit lines or points.
#' @param pt.size,line.size size in pixels (scales to image size if NULL)
#' @param pt.shape the shape of the points ("circle", "cross", "index")
#' @param bg background color ("image" uses the original image)
#'
#' @return list of stimuli with template images
#' @export
#' @family tem
#' @family viz
#'
#' @examples
#' # get an image with 2 different templates
#' stimuli <- demo_tems("frl|fpp106")
#'
#' # default template
#' draw_tem(stimuli)
#'
#' \donttest{
#' # custom template
#' draw_tem(stimuli,
#' pt.shape = "cross",
#' pt.color = "red",
#' pt.alpha = 1,
#' pt.size = 15,
#' line.color = rgb(0, 0, 0),
#' line.alpha = 0.5,
#' line.size = 5)
#'
#' # indexed template
#' draw_tem(stimuli,
#' pt.shape = "index",
#' pt.size = 15,
#' pt.alpha = 1,
#' line.alpha = 0)
#' }
draw_tem <- function(stimuli, pt.color = wm_opts("pt.color"), pt.alpha = 0.75, pt.size = NULL, pt.shape = c("circle", "cross", "index"),
line.color = wm_opts("line.color"), line.alpha = 0.5, line.size = NULL,
bg = "image") {
stimuli <- require_tems(stimuli)
w <- width(stimuli) |> round()
h <- height(stimuli) |> round()
pt.shape <- match.arg(pt.shape)
# scale size to image if NULL
if (is.null(pt.size)) {
pt.size <- pmax(1, w/100) |> round(2)
}
if (is.null(line.size)) {
line.size <- pmax(0.5, w/250) |> round(2)
}
# allow for vectors
# pt and line color and alpha combined below
bg[bg != "image"] <- sapply(bg[bg != "image"], color_conv)
suppressWarnings({
l <- length(stimuli)
pt.color <- rep_len(pt.color, l)
pt.alpha <- rep_len(pt.alpha, l)
pt.size <- rep_len(pt.size %||% 0, l)
line.color <- rep_len(line.color, l)
line.alpha <- rep_len(line.alpha, l)
line.size <- rep_len(line.size %||% 0, l)
bg <- rep_len(bg, l)
})
for (i in seq_along(stimuli)) {
temPoints <- stimuli[[i]]$points
circle_radius <- max(0.1, pt.size[i]/2 - line.size[i]/2)
cross_arm <- pt.size[i]/2
# construct points ----
idx <- -1
points <- round(temPoints, 2) |>
apply(2, function(pts) {
x <- pts[1]
y <- pts[2]
if (pt.shape == "circle") {
sprintf("<circle cx=\"%.2f\" cy=\"%.2f\" r=\"%.2f\"/>",
x, y, circle_radius)
} else if (pt.shape == "cross") {
sprintf("<polygon points=\"%.2f,%.2f %.2f,%.2f %.2f,%.2f %.2f,%.2f %.2f,%.2f %.2f,%.2f %.2f,%.2f %.2f,%.2f %.2f,%.2f\" />",
x, y, x, y-cross_arm, x, y, x+cross_arm, y,
x, y, x, y+cross_arm, x, y, x-cross_arm, y, x, y
)
# sprintf("<line x1=\"%.2f\" x2=\"%.2f\" y1=\"%.2f\" y2=\"%.2f\" />
# <line x1=\"%.2f\" x2=\"%.2f\" y1=\"%.2f\" y2=\"%.2f\" />",
# x, x, y-cross_arm, y+cross_arm,
# x-cross_arm, x+cross_arm, y, y)
} else if (pt.shape == "index") {
idx <<- idx + 1 # dumb but works
sprintf("<text x=\"%.2f\" y=\"%.2f\">%s</text>", x, y+(pt.size/2), idx)
}
}) |>
paste(collapse = "\n ")
# construct Bezier curves for lines ----
if (line.alpha[i] > 0) {
curves <- stimuli[[i]]$lines |>
lapply(function(m) {
v <- temPoints[, m+1]
svgBezier(v, 1)
}) |>
lapply(function(d) {
sprintf("<path d = \"%s\" />",
paste(d, collapse = "\n"))
}) |>
paste(collapse = "\n\n")
} else {
curves <- ""
}
# make SVG ----
svg <- sprintf("<svg width=\"%d\" height=\"%d\" xmlns=\"http://www.w3.org/2000/svg\">
<g id=\"lines\" stroke-width=\"%f\" stroke=\"%s\" fill=\"none\">
%s
</g>
<g id=\"points\" stroke-width=\"%f\" stroke=\"%s\" fill=\"%s\"
font-size=\"%f\" font-weight=\"100\"
font-family=\"FiraCode, Consolas, Courier, monospace\"
text-anchor=\"middle\">
%s
</g>
</svg>",
w[i], h[i], line.size[i],
color_conv(line.color[i], line.alpha[i]), curves,
line.size[i]/2, color_conv(pt.color[i], pt.alpha[i]),
color_conv(pt.color[i], pt.alpha[i]), pt.size[i], points)
temimg <- magick::image_read_svg(svg)
if (bg[i] == "image") {
img <- stimuli[[i]]$img
if (inherits(img, "magick-image")) {
stimuli[[i]]$img <- magick::image_composite(img, temimg)
} else {
stimuli[[i]]$img <- magick::image_background(temimg, wm_opts("fill"))
}
} else if (bg[i] == "none") {
stimuli[[i]]$img <- temimg
} else {
bgcolor <- color_conv(bg[i])
stimuli[[i]]$img <- magick::image_background(temimg, bgcolor)
}
}
stimuli
}