Hi I'm trying to make a server in R shiny, I have the following code:
output$map <- renderTmap( {
cat("renderTmap (initialise map) | ")
if (input$varID == "Temperture") {
tm_basemap(c("Esri.OceanBasemap","CartoDB.DarkMatter","OpenStreetMap.Mapnik"),alpha = 0.7) +
weLayerF(weather,"temp", "feel_like" ,"-RdYlBu", seq(from = 0, to = 45, by = 2))
} else if (input$varID == "humidity") {
tm_basemap(c("Esri.OceanBasemap","CartoDB.DarkMatter","OpenStreetMap.Mapnik"),alpha = 0.7) +
weLayer(weather,"humidity", "YlOrRd", seq(from = 0, to = 100, by = 2))
} else if (input$varID == "Pressure") {
tm_basemap(c("Esri.OceanBasemap","CartoDB.DarkMatter","OpenStreetMap.Mapnik"),alpha = 0.7) +
weLayer(weather,"pressure", "PuBu", seq(from = 980, to = 1030, by = 2))
} else if (input$varID == "Visablity") {
tm_basemap(c("Esri.OceanBasemap","CartoDB.DarkMatter","OpenStreetMap.Mapnik"),alpha = 0.7) +
weLayer(weather,"visib", "-Greys", seq(from = 0, to = 10000, by = 500))
} else if (input$varID == "Wind") {
tm_basemap(c("Esri.OceanBasemap","CartoDB.DarkMatter","OpenStreetMap.Mapnik"),alpha = 0.7) +
weLayerF(weather,"wind_speed","wind_degree", "Greys", seq(from = 0, to = 30, by = 2))
} else {
tm_basemap(c("Esri.OceanBasemap","CartoDB.DarkMatter","OpenStreetMap.Mapnik"),alpha = 0.7) +
weLayerF(weather,"temp", "feel_like" ,"-RdYlBu", seq(from = -10, to = 45, by = 5))
}
})
And I'm getting the error:
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
Can someone help please?
Related
I need to draw a round map in an R object in PowerBI.
Now I use two objects, a transparent circle image and a R visual object (map).
This is the code:
dataset <- data.frame(03. Ciudad origen, lon, lat, 02. Ciudad destino, lon.1, lat.1, zoomMapa)
dataset <- unique(dataset)
par(fg="#f0ecf8")
colnames(dataset) <- c("ciudad_base","lon_base","lat_base","apto_dest","lon_dest","lat_dest","zoomMapa")
library(stringr)
library(maps)
library(geosphere)
library(magrittr)
offset <- unique(dataset$zoomMapa)
plot_my_connection=function( dep_lon, dep_lat, arr_lon, arr_lat, ...){
inter <- gcIntermediate(c(dep_lon, dep_lat), c(arr_lon, arr_lat), n=50, addStartEnd=TRUE, > breakAtDateLine=F)
inter=data.frame(inter)
diff_of_lon=abs(dep_lon) + abs(arr_lon)
if(diff_of_lon > 180){
lines(subset(inter, lon>=0), ...)
lines(subset(inter, lon<0), ...)
}else{
lines(inter, ...)
}
}
dif_lon=function(dep_lon, arr_lon){
ret = 0
if (dep_lon< 0 & arr_lon<0 ){
ret = abs(min(dep_lon, arr_lon)-max(dep_lon, arr_lon))
}
if (dep_lon> 0 & arr_lon>0 ){
ret = abs(max(dep_lon, arr_lon)-min(dep_lon, arr_lon))
}
if (dep_lon> 0 & arr_lon<0 ){
ret = dep_lon - arr_lon
}
if (dep_lon<0 & arr_lon>0 ){
ret = - dep_lon + arr_lon
}
return (ret)
}
dif_lat=function(dep_lat, arr_lat){
ret = 0
if (dep_lat< 0 & arr_lat<0 ){
ret = abs(min(dep_lat, arr_lat)-max(dep_lat, arr_lat))
}
if (dep_lat> 0 & arr_lat>0 ){
ret = abs(max(dep_lat, arr_lat)-min(dep_lat, arr_lat))
}
if (dep_lat> 0 & arr_lat<0 ){
ret = dep_lat - arr_lat
}
if (dep_lat<0 & arr_lat>0 ){
ret = - dep_lat + arr_lat
}
return (ret)
}
lonmin= min(min(dataset$lon_base), min(dataset$lon_dest)) - dataset$zoomMapa
lonmax = max(max(dataset$lon_base), max(dataset$lon_dest)) + dataset$zoomMapa
latmin= min(min(dataset$lat_base), min(dataset$lat_dest)) - dataset$zoomMapa
latmax=max(max(dataset$lat_base), max(dataset$lat_dest)) + dataset$zoomMapa
diflon = dif_lon(lonmin,lonmax)
diflat = dif_lat(latmin, latmax)
off_lon = 0
off_lat = 0
if (diflon > diflat)
off_lat = (diflon-diflat)/2
if (diflon < diflat)
off_lon = (diflat-diflon)/2
lonmin= lonmin - off_lon
lonmax = lonmax + off_lon
latmin= latmin - off_lat
latmax = latmax + off_lat
par(mar=c(0,0,0,0))
map('world', boundary = TRUE, regions = "", interior = TRUE, bg="white", col="#f0ecf8", fill=TRUE, mar = c(0.1, 0.1, 0, 0.1), xlim=c(lonmin,lonmax), ylim=c(latmin,latmax) )
points(x=as.double(dataset$lon_base1), y=as.double(dataset$lat_base1), col="#1a2732", cex=1, pch=1)
text(dataset$ciudad_base1, x=as.double(dataset$lon_base1), y=as.double(dataset$lat_base1), col="#1a2732", cex=1, pos=1)
for(i in 1:nrow(dataset)){
plot_my_connection(as.double(dataset$lon_base[i]), as.double(dataset$lat_base[i]), as.double(dataset$lon_dest[i]),as.double( dataset$lat_dest[i]), col="#1a2732", lwd=1)
points(x=as.double(dataset$lon_dest[i]), y=as.double(dataset$lat_dest[i]), col="#1a2732", cex=1, pch=1)
text(dataset$apto_dest[i], x=as.double(dataset$lon_dest[i]), y=as.double(dataset$lat_dest[i]), col="#1a2732", cex=1, pos=1)
}
The main problem is that for some routes I don't get the map filled, only the rectangle part.
Any tip there?
Thank you very much.
I want to make an animated plot with a 3D surface
I was trying to replicate this example
https://stackoverflow.com/a/66117098/11555164
But I was unable to make it work, is not rotating
library(shiny)
library(plotly)
library(htmlwidgets)
ui <- fluidPage(
plotlyOutput("graph")
)
server <- function(input, output, session) {
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
output$graph <- renderPlotly({
plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = 1.25,
y = 1.25,
z = 1.25
),
center = list(x = 0,
y = 0,
z = 0)
))) %>%
onRender("
function(el, x){
var id = el.getAttribute('id');
var gd = document.getElementById(id);
Plotly.plot(id).then(attach);
function attach() {
var cnt = 0;
function run() {
rotate('scene', Math.PI / 180);
requestAnimationFrame(run);
}
run();
function rotate(id, angle) {
var eye0 = gd.layout[id].camera.eye
var rtz = xyz2rtz(eye0);
rtz.t += angle;
var eye1 = rtz2xyz(rtz);
Plotly.relayout(gd, id + '.camera.eye', eye1)
}
function xyz2rtz(xyz) {
return {
r: Math.sqrt(xyz.x * xyz.x + xyz.y * xyz.y),
t: Math.atan2(xyz.y, xyz.x),
z: xyz.z
};
}
function rtz2xyz(rtz) {
return {
x: rtz.r * Math.cos(rtz.t),
y: rtz.r * Math.sin(rtz.t),
z: rtz.z
};
}
};
}
")
})
}
shinyApp(ui, server)
I don't get any error in the console of Rstudio
I also try to isolate the code, and avoid the use of Shiny (to save it as HTML)
And in Chrome, I get and rendering error when opening the Debugging
This is the second code (without shiny)
#library(shiny)
library(plotly)
library(htmlwidgets)
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = 1.25,
y = 1.25,
z = 1.25
),
center = list(x = 0,
y = 0,
z = 0)
))) %>%
onRender("
function(el, x){
var id = el.getAttribute('id');
var gd = document.getElementById(id);
Plotly.plot(id).then(attach);
function attach() {
var cnt = 0;
function run() {
rotate('scene', Math.PI / 180);
requestAnimationFrame(run);
}
run();
function rotate(id, angle) {
var eye0 = gd.layout[id].camera.eye
var rtz = xyz2rtz(eye0);
rtz.t += angle;
var eye1 = rtz2xyz(rtz);
Plotly.relayout(gd, id + '.camera.eye', eye1)
}
function xyz2rtz(xyz) {
return {
r: Math.sqrt(xyz.x * xyz.x + xyz.y * xyz.y),
t: Math.atan2(xyz.y, xyz.x),
z: xyz.z
};
}
function rtz2xyz(rtz) {
return {
x: rtz.r * Math.cos(rtz.t),
y: rtz.r * Math.sin(rtz.t),
z: rtz.z
};
}
};
}
")
Im missing something on onRender?
Update:
Thanks to #ismirsehregal for the update in the change of Plotly.plot to Plotly.update
You can check the accepted answer
In case you need the version without Shiny, you can use this code
library(plotly)
library(htmlwidgets)
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
PLT <- plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = 1.25,
y = 1.25,
z = 1.25
),
center = list(x = 0,
y = 0,
z = 0)
))) %>%
onRender("
function(el, x){
var id = el.getAttribute('id');
var gd = document.getElementById(id);
Plotly.update(id).then(attach);
function attach() {
var cnt = 0;
function run() {
rotate('scene', Math.PI / 1000);
requestAnimationFrame(run);
}
run();
function rotate(id, angle) {
var eye0 = gd.layout[id].camera.eye
var rtz = xyz2rtz(eye0);
rtz.t += angle;
var eye1 = rtz2xyz(rtz);
Plotly.relayout(gd, id + '.camera.eye', eye1)
}
function xyz2rtz(xyz) {
return {
r: Math.sqrt(xyz.x * xyz.x + xyz.y * xyz.y),
t: Math.atan2(xyz.y, xyz.x),
z: xyz.z
};
}
function rtz2xyz(rtz) {
return {
x: rtz.r * Math.cos(rtz.t),
y: rtz.r * Math.sin(rtz.t),
z: rtz.z
};
}
};
}
")
PLT
R plotly 4.10.0 recently updated the underlying plotly.js library from v1.57.1 to v2.5.1. This includes many breaking changes - With version 2.0 of plotly.js the function Plotly.plot was dropped.
To get back the old behaviour Plotly.plot can be replaced by Plotly.update:
library(shiny)
library(plotly)
library(htmlwidgets)
ui <- fluidPage(
plotlyOutput("graph")
)
server <- function(input, output, session) {
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
output$graph <- renderPlotly({
plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = 1.25,
y = 1.25,
z = 1.25
),
center = list(x = 0,
y = 0,
z = 0)
))) %>%
onRender("
function(el, x){
var id = el.getAttribute('id');
var gd = document.getElementById(id);
Plotly.update(id).then(attach);
function attach() {
var cnt = 0;
function run() {
rotate('scene', Math.PI / 180);
requestAnimationFrame(run);
}
run();
function rotate(id, angle) {
var eye0 = gd.layout[id].camera.eye
var rtz = xyz2rtz(eye0);
rtz.t += angle;
var eye1 = rtz2xyz(rtz);
Plotly.relayout(gd, id + '.camera.eye', eye1)
}
function xyz2rtz(xyz) {
return {
r: Math.sqrt(xyz.x * xyz.x + xyz.y * xyz.y),
t: Math.atan2(xyz.y, xyz.x),
z: xyz.z
};
}
function rtz2xyz(rtz) {
return {
x: rtz.r * Math.cos(rtz.t),
y: rtz.r * Math.sin(rtz.t),
z: rtz.z
};
}
};
}
")
})
}
shinyApp(ui, server)
I'm trying to add a custom animation using highcharter R package like in this example where I use a polar chart.
I'm able to do this using JS, but I can't translate the animation function (from ease repository) to highcharter.
Here is my R code:
# I've tried to created a function using `JS`:
easeOutBounce <- JS("function (pos) {
if ((pos) < (1 / 2.75)) {
return (7.5625 * pos * pos);
}
if (pos < (2 / 2.75)) {
return (7.5625 * (pos -= (1.5 / 2.75)) * pos + 0.75);
}
if (pos < (2.5 / 2.75)) {
return (7.5625 * (pos -= (2.25 / 2.75)) * pos + 0.9375);
}
return (7.5625 * (pos -= (2.625 / 2.75)) * pos + 0.984375);
}")
library(tidyverse)
library(highcharter)
highchart() %>%
hc_chart(polar = T, type = "bar",
events = list(
render = JS("function() {
var chart = this,
middleElement = chart.middleElement;
if (middleElement) {
middleElement.destroy();
}
chart.middleElement = chart.renderer.circle(chart.plotSizeX / 2 + chart.plotLeft, chart.plotHeight / 2 + chart.plotTop, 20).attr({
zIndex: 3,
fill: '#ffffff'
}).add();
}")
)
) %>%
hc_title(text = "Athlete 1 vs Athlete 2") %>%
hc_xAxis(categories = c("Total Score", "Avg. Score", "Sum Score",
"Best Score"),
tickmarkPlacement = "on",
plotLines = list(
list(label = list(
rotation = 90))
)
) %>%
hc_yAxis(offset = 30) %>%
hc_series(
list(
pointPadding = 0,
groupPadding = 0,
name = "Athlete 1",
animatio = list(
duration = 1000,
easing = easeOutBounce
),
data = c(43000, 19000, 60000, 35000)
),
list(
pointPadding = 0,
groupPadding = 0,
name = "Athlete 2",
data = c(50000, 39000, 42000, 31000)
)
) %>%
hc_colors(c("firebrick", "steelblue")) %>%
hc_tooltip(
borderWidth = 0,
backgroundColor = 'none',
shadow = FALSE,
style = list(
fontSize = '16px'
),
headerFormat = '',
pointFormatter = JS("function() {
return this.y / 1000 + 'k'
}"),
positioner = JS("function(labelWidth, labelHeight) {
return {
x: (this.chart.plotSizeX - labelWidth) / 2 + this.chart.plotLeft,
y: (this.chart.plotSizeY - labelHeight) / 2 + this.chart.plotTop
};
}")
)
Thank you!
Animation doesn't work because you have a little typo in attached code. Please take a look on it:
animatio = list(
duration = 1000,
easing = easeOutBounce
),
Should be animation, not animatio. Please correct it, then animation should appear.
My goal is to call my dice roll function n times where n is the amount of turns. This is a monopoly simulated turn and as such the doubles will roll again, and triples will go to jail. I cannot figure out how to set this up so my function will be
Diceroll <- Function ( Turns, Sides)
Diceroll <- function(Turn,sides){
Turn = as.integer(0)
First_roll = as.integer(0)
Second_roll = as.integer(0)
Third_roll = as.integer(0)
Fourth_roll = as.integer(0)
Fifth_roll = as.integer(0)
Sixth_roll = as.integer(0)
Total = as.integer(0)
i = as.integer(1)
for (i in 1:Turn) {
First_roll = sample(1:sides,size = 1)
Second_roll = sample(1:sides,size = 1)
if(First_roll[1] == Second_roll[1]) {
Third_roll = sample(1:sides,size = 1)
Fourth_roll = sample(1:sides,size = 1)
}
if(Third_roll[1] == Fourth_roll[1] & Third_roll[1] + Fourth_roll[1] > 0) {
Fifth_roll= sample(1:sides,size = 1)
Sixth_roll = sample(1:sides,size = 1)
}
if(Fifth_roll[1] == Sixth_roll[1] & Fifth_roll[1] + Sixth_roll[1] > 0) { Total = "Jail"
}
else {
Total = (First_roll[1] + Second_roll[1] + Third_roll[1] +
Fourth_roll[1] + Fifth_roll[1] + Sixth_roll[1]) }
return(Total)
}
}
Here is my attempt but it is only listed the value of one roll.
I need to make a function which call Oracle R Enterprise ore.corr function and output result as a data.frame.
My R code here:
f_sts_corelation =
function(dat, target_col="",corr_type="spearman",group_by="")
{
v_target_col = gsub("\n","",target_col, fixed = TRUE);
v_target_col_list = "";
library("gdata");
for (s_name in strsplit(v_target_col,",")[[1]])
{
n_pos = regexpr(".",s_name,fixed = TRUE);
if (n_pos > 0)
{
s_name = substring(s_name,n_pos+1);
}
s_name = gsub("\"","",s_name, fixed = TRUE);
if (is.numeric(dat[,trim(s_name)]))
{
if (nchar(v_target_col_list)== 0)
{
v_target_col_list = trim(s_name)
}
else
{
v_target_col_list =paste(v_target_col_list,",",trim(s_name))
}
}
}
ore.data = ore.push(dat)
v_id = c()
v_group=c()
v_row = c()
v_col = c()
v_statistic = c()
v_pvalue = c()
v_df = c()
#group_by = ""
s_group_by = trim(gsub("\n","",group_by, fixed = TRUE));
if (nchar(s_group_by) > 0)
{
n_pos = regexpr(".",s_group_by,fixed = TRUE);
if (n_pos > 0)
{
s_group_by = substring(s_group_by,n_pos+1);
}
s_group_by = trim(gsub("\"","",s_group_by, fixed = TRUE));
ore.corr.res = ore.corr(ore.data,var = v_target_col_list, group.by = s_group_by)
for (i in 1:length(ore.corr.res))
{
if (i == 1)
{
v_group = rep(names(ore.corr.res[i]),length(ore.corr.res[[i]]$ROW))
v_row = as.vector(ore.corr.res[[i]]$ROW)
v_col = as.vector(ore.corr.res[[i]]$COL)
v_statistic = as.vector(ore.corr.res[[i]][,3])
v_pvalue = as.vector(ore.corr.res[[i]][,4])
v_df = as.vector(ore.corr.res[[i]][,5])
}
else
{
v_group = c(v_group,rep(names(ore.corr.res[i]),length(ore.corr.res[[i]]$ROW)))
v_row = c(v_row,as.vector(ore.corr.res[[i]]$ROW))
v_col = c(v_col,as.vector(ore.corr.res[[i]]$COL))
v_statistic = c(v_statistic,as.vector(ore.corr.res[[i]][,3]))
v_pvalue = c(v_pvalue,as.vector(ore.corr.res[[i]][,4]))
v_df = c(v_df,as.vector(ore.corr.res[[i]][,5]))
}
}
}
else if(nchar(s_group_by) == 0)
{
ore.corr.res = ore.corr(ore.data,var = v_target_col_list)
v_group = rep(" ",length(ore.corr.res$ROW))
v_row = as.vector(ore.corr.res$ROW)
v_col = as.vector(ore.corr.res$COL)
v_statistic = as.vector(ore.corr.res[,3])
v_pvalue = as.vector(ore.corr.res[,4])
v_df = as.vector(ore.corr.res[,5])
}
df_res = data.frame(Group_by = v_group,
Row = v_row,
Col = v_col,
Statistic = v_statistic,
P_Value = v_pvalue,
DF = v_df)
}
After that, I run the function by following script:
dat = iris;
corr_type="spearman";
V_target_col= '"IRIS_N$10002"."Sepal.Length",
"IRIS_N$10002"."Sepal.Width",
"IRIS_N$10002"."Petal.Width",
"IRIS_N$10002"."Petal.Length"';
group_by =
'
"IRIS_N$10002"."Species"
'
df_result = f_sts_corelation(dat,target_col = target_col, group_by = group_by)
But following error happen.
Error: ORE object has no unique key
I have tried to run each R command inside my function step by step and I sure that the Error happen from the last R command:
df_res = data.frame(Group_by = v_group,
Row = v_row,
Col = v_col,
Statistic = v_statistic,
P_Value = v_pvalue,
DF = v_df)
I don't know how to avoid this error.